home *** CD-ROM | disk | FTP | other *** search
Text File | 1998-10-28 | 155.1 KB | 4,545 lines |
- ;;; edebug.el --- a source-level debugger for Emacs Lisp
-
- ;; Copyright (C) 1988,'89,'90,'91,'92,'93,'94,'95 Free Software Foundation, Inc
-
- ;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu>
- ;; Keywords: lisp, tools, maint
-
- ;; LCD Archive Entry:
- ;; edebug|Daniel LaLiberte|liberte@cs.uiuc.edu
- ;; |A source level debugger for Emacs Lisp.
- ;; |$Date: 1996/07/24 16:36:41 $|$Revision: 3.8 $|~/modes/edebug.el|
-
- ;; This file is part of GNU Emacs.
-
- ;; GNU Emacs is free software; you can redistribute it and/or modify
- ;; it under the terms of the GNU General Public License as published by
- ;; the Free Software Foundation; either version 2, or (at your option)
- ;; any later version.
-
- ;; GNU Emacs is distributed in the hope that it will be useful,
- ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;; GNU General Public License for more details.
-
- ;; You should have received a copy of the GNU General Public License
- ;; along with GNU Emacs; see the file COPYING. If not, write to the
- ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
- ;; Boston, MA 02111-1307, USA.
-
- ;;; Commentary:
-
- ;; This minor mode allows programmers to step through Emacs Lisp
- ;; source code while executing functions. You can also set
- ;; breakpoints, trace (stopping at each expression), evaluate
- ;; expressions as if outside Edebug, reevaluate and display a list of
- ;; expressions, trap errors normally caught by debug, and display a
- ;; debug style backtrace.
-
- ;;; Installation
- ;; =============
-
- ;; Put edebug.el in some directory in your load-path and
- ;; byte-compile it. Also read the beginning of edebug-epoch.el,
- ;; cl-specs.el, and edebug-cl-read.el if they apply to you.
-
- ;; Unless you are using Emacs 19 which is already set up to use Edebug,
- ;; put the following forms in your .emacs file.
- ;; (define-key emacs-lisp-mode-map "\C-xx" 'edebug-eval-top-level-form)
- ;; (autoload 'edebug-eval-top-level-form "edebug")
-
- ;; If you wish to change the default edebug global command prefix, change:
- ;; (setq edebug-global-prefix "\C-xX")
-
- ;; Other options, are described in the manual.
-
- ;; In previous versions of Edebug, users were directed to set
- ;; `debugger' to `edebug-debug'. This is no longer necessary
- ;; since Edebug automatically sets it whenever Edebug is active.
-
- ;;; Minimal Instructions
- ;; =====================
-
- ;; First evaluate a defun with C-xx, then run the function. Step
- ;; through the code with SPC, mark breakpoints with b, go until a
- ;; breakpoint is reached with g, and quit execution with q. Use the
- ;; "?" command in edebug to describe other commands. See edebug.tex
- ;; or the Emacs 19 Lisp Reference Manual for more instructions.
-
- ;; Send me your enhancements, ideas, bugs, or fixes.
- ;; For bugs, you can call edebug-submit-bug-report if you have reporter.el.
- ;; There is an edebug mailing list if you want to keep up
- ;; with the latest developments. Requests to: edebug-request@cs.uiuc.edu
-
- ;; Daniel LaLiberte 217-398-4114
- ;; University of Illinois, Urbana-Champaign
- ;; Department of Computer Science
- ;; 1304 W Springfield
- ;; Urbana, IL 61801
-
- ;; uiucdcs!liberte
- ;; liberte@cs.uiuc.edu
-
- ;; For the early revision history, see edebug-history.
-
- ;;; Code:
-
- (defconst edebug-version
- (let ((raw-version "$Revision: 3.8 $"))
- (substring raw-version (string-match "[0-9.]*" raw-version)
- (match-end 0))))
-
- (require 'backquote)
-
- ;; Emacs 18 doesn't have defalias.
- (eval-and-compile
- (or (fboundp 'defalias) (fset 'defalias 'fset)))
-
-
- ;;; Bug reporting
-
- (defconst edebug-maintainer-address "liberte@cs.uiuc.edu")
-
- (defun edebug-submit-bug-report ()
- "Submit, via mail, a bug report on edebug."
- (interactive)
- (require 'reporter)
- (and (y-or-n-p "Do you really want to submit a report on edebug? ")
- (reporter-submit-bug-report
- edebug-maintainer-address
- (concat "edebug.el " edebug-version)
- (list 'edebug-setup-hook
- 'edebug-all-defs
- 'edebug-all-forms
- 'edebug-eval-macro-args
- 'edebug-stop-before-symbols
- 'edebug-save-windows
- 'edebug-save-displayed-buffer-points
- 'edebug-initial-mode
- 'edebug-trace
- 'edebug-test-coverage
- 'edebug-continue-kbd-macro
- 'edebug-print-length
- 'edebug-print-level
- 'edebug-print-circle
- ))))
-
- ;;; Options
-
- (defvar edebug-setup-hook nil
- "*Functions to call before edebug is used.
- Each time it is set to a new value, Edebug will call those functions
- once and then `edebug-setup-hook' is reset to nil. You could use this
- to load up Edebug specifications associated with a package you are
- using but only when you also use Edebug.")
-
- (defvar edebug-all-defs nil
- "*If non-nil, evaluation of any defining forms will instrument for Edebug.
- This applies to `eval-defun', `eval-region', `eval-buffer', and
- `eval-current-buffer'. `eval-region' is also called by
- `eval-last-sexp', and `eval-print-last-sexp'.
-
- You can use the command `edebug-all-defs' to toggle the value of this
- variable. You may wish to make it local to each buffer with
- \(make-local-variable 'edebug-all-defs) in your
- `emacs-lisp-mode-hook'.")
-
- (defvar edebug-all-forms nil
- "*Non-nil evaluation of all forms will instrument for Edebug.
- This doesn't apply to loading or evaluations in the minibuffer.
- Use the command `edebug-all-forms' to toggle the value of this option.")
-
- (defvar edebug-eval-macro-args nil
- "*Non-nil means all macro call arguments may be evaluated.
- If this variable is nil, the default, Edebug will *not* wrap
- macro call arguments as if they will be evaluated.
- For each macro, a `edebug-form-spec' overrides this option.
- So to specify exceptions for macros that have some arguments evaluated
- and some not, you should specify an `edebug-form-spec'.
-
- This option is going away soon.")
-
- (defvar edebug-stop-before-symbols nil
- "*Non-nil causes Edebug to stop before symbols as well as after.
- In any case, a breakpoint or interrupt may stop before a symbol.
-
- This option is going away soon.")
-
- (defvar edebug-save-windows t
- "*If non-nil, Edebug saves and restores the window configuration.
- That takes some time, so if your program does not care what happens to
- the window configurations, it is better to set this variable to nil.
-
- If the value is a list, only the listed windows are saved and
- restored.
-
- `edebug-toggle-save-windows' may be used to change this variable.")
-
- (defvar edebug-save-displayed-buffer-points nil
- "*If non-nil, save and restore point in all displayed buffers.
-
- Saving and restoring point in other buffers is necessary if you are
- debugging code that changes the point of a buffer which is displayed
- in a non-selected window. If Edebug or the user then selects the
- window, the buffer's point will be changed to the window's point.
-
- Saving and restoring point in all buffers is expensive, since it
- requires selecting each window twice, so enable this only if you need
- it.")
-
- (defvar edebug-initial-mode 'step
- "*Initial execution mode for Edebug, if non-nil. If this variable
- is non-@code{nil}, it specifies the initial execution mode for Edebug
- when it is first activated. Possible values are step, next, go,
- Go-nonstop, trace, Trace-fast, continue, and Continue-fast.")
-
- (defvar edebug-trace nil
- "*Non-nil means display a trace of function entry and exit.
- Tracing output is displayed in a buffer named `*edebug-trace*', one
- function entry or exit per line, indented by the recursion level.
-
- You can customize by replacing functions `edebug-print-trace-before'
- and `edebug-print-trace-after'.")
-
- (defvar edebug-test-coverage nil
- "*If non-nil, Edebug tests coverage of all expressions debugged.
- This is done by comparing the result of each expression
- with the previous result. Coverage is considered OK if two different
- results are found.
-
- Use `edebug-display-freq-count' to display the frequency count and
- coverage information for a definition.")
-
- (defvar edebug-continue-kbd-macro nil
- "*If non-nil, continue defining or executing any keyboard macro.
- Use this with caution since it is not debugged.")
-
-
- (defvar edebug-print-length 50
- "*Default value of `print-length' to use while printing results in Edebug.")
- (defvar edebug-print-level 50
- "*Default value of `print-level' to use while printing results in Edebug.")
- (defvar edebug-print-circle t
- "*Default value of `print-circle' to use while printing results in Edebug.")
-
- (defvar edebug-unwrap-results nil
- "*Non-nil if Edebug should unwrap results of expressions.
- This is useful when debugging macros where the results of expressions
- are instrumented expressions. But don't do this when results might be
- circular or an infinite loop will result.")
-
- (defvar edebug-on-error t
- "*Value bound to `debug-on-error' while Edebug is active.
-
- If `debug-on-error' is non-nil, that value is still used.
-
- If the value is a list of signal names, Edebug will stop when any of
- these errors are signaled from Lisp code whether or not the signal is
- handled by a `condition-case'. This option is useful for debugging
- signals that *are* handled since they would otherwise be missed.
- After execution is resumed, the error is signaled again.")
-
- (defvar edebug-on-quit t
- "*Value bound to `debug-on-quit' while Edebug is active.")
-
- (defvar edebug-global-break-condition nil
- "*If non-nil, an expression to test for at every stop point.
- If the result is non-nil, then break. Errors are ignored.")
-
- ;;; Form spec utilities.
-
- ;;;###autoload
- (defmacro def-edebug-spec (symbol spec)
- "Set the edebug-form-spec property of SYMBOL according to SPEC.
- Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol
- \(naming a function), or a list."
- (` (put (quote (, symbol)) 'edebug-form-spec (quote (, spec)))))
-
- (defmacro def-edebug-form-spec (symbol spec-form)
- "For compatibility with old version. Use `def-edebug-spec' instead."
- (message "Obsolete: use def-edebug-spec instead.")
- (def-edebug-spec symbol (eval spec-form)))
-
- (defun get-edebug-spec (symbol)
- ;; Get the spec of symbol resolving all indirection.
- (let ((edebug-form-spec (get symbol 'edebug-form-spec))
- indirect)
- (while (and (symbolp edebug-form-spec)
- (setq indirect (get edebug-form-spec 'edebug-form-spec)))
- ;; (edebug-trace "indirection: %s" edebug-form-spec)
- (setq edebug-form-spec indirect))
- edebug-form-spec
- ))
-
- ;;; Utilities
-
- ;; Define edebug-gensym - from old cl.el
- (defvar edebug-gensym-index 0
- "Integer used by `edebug-gensym' to produce new names.")
-
- (defun edebug-gensym (&optional prefix)
- "Generate a fresh uninterned symbol.
- There is an optional argument, PREFIX. PREFIX is the
- string that begins the new name. Most people take just the default,
- except when debugging needs suggest otherwise."
- (if (null prefix)
- (setq prefix "G"))
- (let ((newsymbol nil)
- (newname ""))
- (while (not newsymbol)
- (setq newname (concat prefix (int-to-string edebug-gensym-index)))
- (setq edebug-gensym-index (+ edebug-gensym-index 1))
- (if (not (intern-soft newname))
- (setq newsymbol (make-symbol newname))))
- newsymbol))
-
- ;; Only used by CL-like code.
- (defun edebug-keywordp (object)
- "Return t if OBJECT is a keyword.
- A keyword is a symbol that starts with `:'."
- (and (symbolp object)
- (= ?: (aref (symbol-name object) 0))))
-
- (defun edebug-lambda-list-keywordp (object)
- "Return t if OBJECT is a lambda list keyword.
- A lambda list keyword is a symbol that starts with `&'."
- (and (symbolp object)
- (= ?& (aref (symbol-name object) 0))))
-
-
- (defun edebug-last-sexp ()
- ;; Return the last sexp before point in current buffer.
- ;; Assumes Emacs Lisp syntax is active.
- (car
- (read-from-string
- (buffer-substring
- (save-excursion
- (forward-sexp -1)
- (point))
- (point)))))
-
- (defun edebug-window-list ()
- "Return a list of windows, in order of `next-window'."
- ;; This doesn't work for epoch.
- (let* ((first-window (selected-window))
- (window-list (list first-window))
- (next (next-window first-window)))
- (while (not (eq next first-window))
- (setq window-list (cons next window-list))
- (setq next (next-window next)))
- (nreverse window-list)))
-
- (defun edebug-window-live-p (window)
- "Return non-nil if WINDOW is visible."
- (let* ((first-window (selected-window))
- (next (next-window first-window t)))
- (while (not (or (eq next window)
- (eq next first-window)))
- (setq next (next-window next t)))
- (eq next window)))
-
- ;; Not used.
- '(defun edebug-two-window-p ()
- "Return t if there are two windows."
- (and (not (one-window-p))
- (eq (selected-window)
- (next-window (next-window (selected-window))))))
-
- (defsubst edebug-lookup-function (object)
- (while (and (symbolp object) (fboundp object))
- (setq object (symbol-function object)))
- object)
-
- (defun edebug-macrop (object)
- "Return the macro named by OBJECT, or nil if it is not a macro."
- (setq object (edebug-lookup-function object))
- (if (and (listp object)
- (eq 'macro (car object))
- (edebug-functionp (cdr object)))
- object))
-
- (defun edebug-functionp (object)
- "Returns the function named by OBJECT, or nil if it is not a function."
- (setq object (edebug-lookup-function object))
- (if (or (subrp object)
- (byte-code-function-p object)
- (and (listp object)
- (eq (car object) 'lambda)
- (listp (car (cdr object)))))
- object))
-
- (defun edebug-sort-alist (alist function)
- ;; Return the ALIST sorted with comparison function FUNCTION.
- ;; This uses 'sort so the sorting is destructive.
- (sort alist (function
- (lambda (e1 e2)
- (funcall function (car e1) (car e2))))))
-
- ;;(def-edebug-spec edebug-save-restriction t)
-
- ;; Not used. If it is used, def-edebug-spec must be defined before use.
- '(defmacro edebug-save-restriction (&rest body)
- "Evaluate BODY while saving the current buffers restriction.
- BODY may change buffer outside of current restriction, unlike
- save-restriction. BODY may change the current buffer,
- and the restriction will be restored to the original buffer,
- and the current buffer remains current.
- Return the result of the last expression in BODY."
- (` (let ((edebug:s-r-beg (point-min-marker))
- (edebug:s-r-end (point-max-marker)))
- (unwind-protect
- (progn (,@ body))
- (save-excursion
- (set-buffer (marker-buffer edebug:s-r-beg))
- (narrow-to-region edebug:s-r-beg edebug:s-r-end))))))
-
- ;;; Display
-
- (defconst edebug-trace-buffer "*edebug-trace*"
- "Name of the buffer to put trace info in.")
-
- (defun edebug-pop-to-buffer (buffer &optional window)
- ;; Like pop-to-buffer, but select window where BUFFER was last shown.
- ;; Select WINDOW if it provided and it still exists. Otherwise,
- ;; if buffer is currently shown in several windows, choose one.
- ;; Otherwise, find a new window, possibly splitting one.
- (setq window (if (and (windowp window) (edebug-window-live-p window)
- (eq (window-buffer window) buffer))
- window
- (if (eq (window-buffer (selected-window)) buffer)
- (selected-window)
- (edebug-get-buffer-window buffer))))
- (if window
- (select-window window)
- (if (one-window-p)
- (split-window))
- ;; (message "next window: %s" (next-window)) (sit-for 1)
- (if (eq (get-buffer-window edebug-trace-buffer) (next-window))
- ;; Don't select trace window
- nil
- (select-window (next-window))))
- (set-window-buffer (selected-window) buffer)
- (set-window-hscroll (selected-window) 0);; should this be??
- ;; Selecting the window does not set the buffer until command loop.
- ;;(set-buffer buffer)
- )
-
-
- (defun edebug-get-displayed-buffer-points ()
- ;; Return a list of buffer point pairs, for all displayed buffers.
- (save-excursion
- (let* ((first-window (selected-window))
- (next (next-window first-window))
- (buffer-point-list nil)
- buffer)
- (while (not (eq next first-window))
- (set-buffer (setq buffer (window-buffer next)))
- (setq buffer-point-list
- (cons (cons buffer (point)) buffer-point-list))
- (setq next (next-window next)))
- buffer-point-list)))
-
-
- (defun edebug-set-buffer-points (buffer-points)
- ;; Restore the buffer-points created by edebug-get-displayed-buffer-points.
- (let ((current-buffer (current-buffer)))
- (mapcar (function (lambda (buf-point)
- (if (buffer-name (car buf-point)) ; still exists
- (progn
- (set-buffer (car buf-point))
- (goto-char (cdr buf-point))))))
- buffer-points)
- (set-buffer current-buffer)))
-
- (defun edebug-current-windows (which-windows)
- ;; Get either a full window configuration or some window information.
- (if (listp which-windows)
- (mapcar (function (lambda (window)
- (if (edebug-window-live-p window)
- (list window
- (window-buffer window)
- (window-point window)
- (window-start window)
- (window-hscroll window)))))
- which-windows)
- (current-window-configuration)))
-
- (defun edebug-set-windows (window-info)
- ;; Set either a full window configuration or some window information.
- (if (listp window-info)
- (mapcar (function
- (lambda (one-window-info)
- (if one-window-info
- (apply (function
- (lambda (window buffer point start hscroll)
- (if (edebug-window-live-p window)
- (progn
- (set-window-buffer window buffer)
- (set-window-point window point)
- (set-window-start window start)
- (set-window-hscroll window hscroll)))))
- one-window-info))))
- window-info)
- (set-window-configuration window-info)))
-
- (defalias 'edebug-get-buffer-window 'get-buffer-window)
- (defalias 'edebug-sit-for 'sit-for)
- (defalias 'edebug-input-pending-p 'input-pending-p)
-
-
- ;;; Redefine read and eval functions
- ;; read is redefined to maybe instrument forms.
- ;; eval-defun is redefined to check edebug-all-forms and edebug-all-defs.
-
- ;; Use the Lisp version of eval-region.
- (require 'eval-reg "eval-reg")
-
- ;; Save the original read function
- (or (fboundp 'edebug-original-read)
- (defalias 'edebug-original-read (symbol-function 'read)))
-
- (defun edebug-read (&optional stream)
- "Read one Lisp expression as text from STREAM, return as Lisp object.
- If STREAM is nil, use the value of `standard-input' (which see).
- STREAM or the value of `standard-input' may be:
- a buffer (read from point and advance it)
- a marker (read from where it points and advance it)
- a function (call it with no arguments for each character,
- call it with a char as argument to push a char back)
- a string (takes text from string, starting at the beginning)
- t (read text line using minibuffer and use it).
-
- This version, from Edebug, maybe instruments the expression. But the
- STREAM must be the current buffer to do so. Whether it instruments is
- also dependent on the values of `edebug-all-defs' and
- `edebug-all-forms'."
- (or stream (setq stream standard-input))
- (if (eq stream (current-buffer))
- (edebug-read-and-maybe-wrap-form)
- (edebug-original-read stream)))
-
- (or (fboundp 'edebug-original-eval-defun)
- (defalias 'edebug-original-eval-defun (symbol-function 'eval-defun)))
-
- ;; We should somehow arrange to be able to do this
- ;; without actually replacing the eval-defun command.
- (defun edebug-eval-defun (edebug-it)
- "Evaluate the top-level form containing point, or after point.
-
- This version, from Edebug, has the following differences: With a
- prefix argument instrument the code for Edebug. If `edebug-all-defs' is
- non-nil, then the code is instrumented *unless* there is a prefix
- argument. If instrumenting, it prints: `Edebug: FUNCTIONNAME'.
- Otherwise, it prints in the minibuffer."
- (interactive "P")
- (let* ((edebugging (not (eq (not edebug-it) (not edebug-all-defs))))
- (edebug-result)
- (form
- (let ((edebug-all-forms edebugging)
- (edebug-all-defs (eq edebug-all-defs (not edebug-it))))
- (edebug-read-top-level-form))))
- (if (and (eq (car form) 'defvar)
- (cdr-safe (cdr-safe form)))
- (setq form (cons 'defconst (cdr form))))
- (setq edebug-result (eval form))
- (if (not edebugging)
- (princ edebug-result)
- edebug-result)))
-
-
- ;;;###autoload
- (defalias 'edebug-defun 'edebug-eval-top-level-form)
-
- ;;;###autoload
- (defun edebug-eval-top-level-form ()
- "Evaluate a top level form, such as a defun or defmacro.
- This is like `eval-defun', but the code is always instrumented for Edebug.
- Print its name in the minibuffer and leave point where it is,
- or if an error occurs, leave point after it with mark at the original point."
- (interactive)
- (eval
- ;; Bind edebug-all-forms only while reading, not while evalling
- ;; but this causes problems while edebugging edebug.
- (let ((edebug-all-forms t)
- (edebug-all-defs t))
- (edebug-read-top-level-form))))
-
-
- (defun edebug-read-top-level-form ()
- (let ((starting-point (point)))
- (end-of-defun)
- (beginning-of-defun)
- (prog1
- (edebug-read-and-maybe-wrap-form)
- ;; Recover point, but only if no error occurred.
- (goto-char starting-point))))
-
-
- ;; Compatibility with old versions.
- (defalias 'edebug-all-defuns 'edebug-all-defs)
-
- (defun edebug-all-defs ()
- "Toggle edebugging of all definitions."
- (interactive)
- (setq edebug-all-defs (not edebug-all-defs))
- (message "Edebugging all definitions is %s."
- (if edebug-all-defs "on" "off")))
-
-
- (defun edebug-all-forms ()
- "Toggle edebugging of all forms."
- (interactive)
- (setq edebug-all-forms (not edebug-all-forms))
- (message "Edebugging all forms is %s."
- (if edebug-all-forms "on" "off")))
-
-
- (defun edebug-install-read-eval-functions ()
- (interactive)
- ;; Don't install if already installed.
- (if (eq (symbol-function 'read) 'edebug-read) nil
- (elisp-eval-region-install)
- (defalias 'read 'edebug-read)
- (defalias 'eval-defun 'edebug-eval-defun)))
-
- (defun edebug-uninstall-read-eval-functions ()
- (interactive)
- (elisp-eval-region-uninstall)
- (defalias 'read (symbol-function 'edebug-original-read))
- (defalias 'eval-defun (symbol-function 'edebug-original-eval-defun)))
-
-
- ;;; Edebug internal data
-
- ;; The internal data that is needed for edebugging is kept in the
- ;; buffer-local variable `edebug-form-data'.
-
- (make-variable-buffer-local 'edebug-form-data)
-
- (defconst edebug-form-data nil)
- ;; A list of entries associating symbols with buffer regions.
- ;; This is an automatic buffer local variable. Each entry looks like:
- ;; @code{(@var{symbol} @var{begin-marker} @var{end-marker}). The markers
- ;; are at the beginning and end of an entry level form and @var{symbol} is
- ;; a symbol that holds all edebug related information for the form on its
- ;; property list.
-
- ;; In the future, the symbol will be irrelevant and edebug data will
- ;; be stored in the definitions themselves rather than in the property
- ;; list of a symbol.
-
- (defun edebug-make-form-data-entry (symbol begin end)
- (list symbol begin end))
-
- (defsubst edebug-form-data-name (entry)
- (car entry))
-
- (defsubst edebug-form-data-begin (entry)
- (nth 1 entry))
-
- (defsubst edebug-form-data-end (entry)
- (nth 2 entry))
-
- (defsubst edebug-set-form-data-entry (entry name begin end)
- (setcar entry name);; in case name is changed
- (set-marker (nth 1 entry) begin)
- (set-marker (nth 2 entry) end))
-
- (defun edebug-get-form-data-entry (pnt &optional end-point)
- ;; Find the edebug form data entry which is closest to PNT.
- ;; If END-POINT is supplied, match must be exact.
- ;; Return `nil' if none found.
- (let ((rest edebug-form-data)
- closest-entry
- (closest-dist 999999)) ;; need maxint here
- (while (and rest (< 0 closest-dist))
- (let* ((entry (car rest))
- (begin (edebug-form-data-begin entry))
- (dist (- pnt begin)))
- (setq rest (cdr rest))
- (if (and (<= 0 dist)
- (< dist closest-dist)
- (or (not end-point)
- (= end-point (edebug-form-data-end entry)))
- (<= pnt (edebug-form-data-end entry)))
- (setq closest-dist dist
- closest-entry entry))))
- closest-entry))
-
- ;; Also need to find all contained entries,
- ;; and find an entry given a symbol, which should be just assq.
-
- (defun edebug-form-data-symbol ()
- ;; Return the edebug data symbol of the form where point is in.
- ;; If point is not inside a edebuggable form, cause error.
- (or (edebug-form-data-name (edebug-get-form-data-entry (point)))
- (error "Not inside instrumented form")))
-
- (defun edebug-make-top-form-data-entry (new-entry)
- ;; Make NEW-ENTRY the first element in the `edebug-form-data' list.
- (edebug-clear-form-data-entry new-entry)
- (setq edebug-form-data (cons new-entry edebug-form-data)))
-
- (defun edebug-clear-form-data-entry (entry)
- ;; If non-nil, clear ENTRY out of the form data.
- ;; Maybe clear the markers and delete the symbol's edebug property?
- (if entry
- (progn
- ;; Instead of this, we could just find all contained forms.
- ;; (put (car entry) 'edebug nil) ;
- ;; (mapcar 'edebug-clear-form-data-entry ; dangerous
- ;; (get (car entry) 'edebug-dependents))
- ;; (set-marker (nth 1 entry) nil)
- ;; (set-marker (nth 2 entry) nil)
- (setq edebug-form-data (delq entry edebug-form-data)))))
-
- ;;; Parser utilities
-
- (defun edebug-syntax-error (&rest args)
- ;; Signal an invalid-read-syntax with ARGS.
- (signal 'invalid-read-syntax args))
-
-
- (defconst edebug-read-syntax-table
- ;; Lookup table for significant characters indicating the class of the
- ;; token that follows. This is not a \"real\" syntax table.
- (let ((table (make-vector 256 'symbol))
- (i 0))
- (while (< i ?!)
- (aset table i 'space)
- (setq i (1+ i)))
- (aset table ?\( 'lparen)
- (aset table ?\) 'rparen)
- (aset table ?\' 'quote)
- (aset table ?\` 'backquote)
- (aset table ?\, 'comma)
- (aset table ?\" 'string)
- (aset table ?\? 'char)
- (aset table ?\[ 'lbracket)
- (aset table ?\] 'rbracket)
- (aset table ?\. 'dot)
- (aset table ?\# 'hash)
- ;; We treat numbers as symbols, because of confusion with -, -1, and 1-.
- ;; We don't care about any other chars since they won't be seen.
- table))
-
- (defun edebug-next-token-class ()
- ;; Move to the next token and return its class. We only care about
- ;; lparen, rparen, dot, quote, backquote, comma, string, char, vector,
- ;; or symbol.
- (edebug-skip-whitespace)
- (aref edebug-read-syntax-table (following-char)))
-
-
- (defun edebug-skip-whitespace ()
- ;; Leave point before the next token, skipping white space and comments.
- (skip-chars-forward " \t\r\n\f")
- (while (= (following-char) ?\;)
- ;; \r is counted as a comment terminator to support selective display.
- (skip-chars-forward "^\n\r") ; skip the comment
- (skip-chars-forward " \t\r\n\f")))
-
-
- ;; Mostly obsolete reader; still used in one case.
-
- (defun edebug-read-sexp ()
- ;; Read one sexp from the current buffer starting at point.
- ;; Leave point immediately after it. A sexp can be a list or atom.
- ;; An atom is a symbol (or number), character, string, or vector.
- ;; This works for reading anything legitimate, but it
- ;; is gummed up by parser inconsistencies (bugs?)
- (let ((class (edebug-next-token-class)))
- (cond
- ;; read goes one too far if a (possibly quoted) string or symbol
- ;; is immediately followed by non-whitespace.
- ((eq class 'symbol) (prog1
- (edebug-original-read (current-buffer))
- (if (not (eq (aref edebug-read-syntax-table
- (preceding-char)) 'symbol))
- (forward-char -1))))
- ((eq class 'string) (prog1
- (edebug-original-read (current-buffer))
- (if (/= (preceding-char) ?\")
- (forward-char -1))))
- ((eq class 'quote) (forward-char 1)
- (list 'quote (edebug-read-sexp)))
- ((eq class 'backquote)
- (list '\` (edebug-read-sexp)))
- ((eq class 'comma)
- (list '\, (edebug-read-sexp)))
- (t ; anything else, just read it.
- (edebug-original-read (current-buffer))))))
-
- ;;; Offsets for reader
-
- ;; Define a structure to represent offset positions of expressions.
- ;; Each offset structure looks like: (before . after) for constituents,
- ;; or for structures that have elements: (before <subexpressions> . after)
- ;; where the <subexpressions> are the offset structures for subexpressions
- ;; including the head of a list.
- (defconst edebug-offsets nil)
-
- ;; Stack of offset structures in reverse order of the nesting.
- ;; This is used to get back to previous levels.
- (defconst edebug-offsets-stack nil)
- (defconst edebug-current-offset nil) ; Top of the stack, for convenience.
-
- ;; We must store whether we just read a list with a dotted form that
- ;; is itself a list. This structure will be condensed, so the offsets
- ;; must also be condensed.
- (defconst edebug-read-dotted-list nil)
-
- (defsubst edebug-initialize-offsets ()
- ;; Reinitialize offset recording.
- (setq edebug-current-offset nil))
-
- (defun edebug-store-before-offset (point)
- ;; Add a new offset pair with POINT as the before offset.
- (let ((new-offset (list point)))
- (if edebug-current-offset
- (setcdr edebug-current-offset
- (cons new-offset (cdr edebug-current-offset)))
- ;; Otherwise, we are at the top level, so initialize.
- (setq edebug-offsets new-offset
- edebug-offsets-stack nil
- edebug-read-dotted-list nil))
- ;; Cons the new offset to the front of the stack.
- (setq edebug-offsets-stack (cons new-offset edebug-offsets-stack)
- edebug-current-offset new-offset)
- ))
-
- (defun edebug-store-after-offset (point)
- ;; Finalize the current offset struct by reversing it and
- ;; store POINT as the after offset.
- (if (not edebug-read-dotted-list)
- ;; Just reverse the offsets of all subexpressions.
- (setcdr edebug-current-offset (nreverse (cdr edebug-current-offset)))
-
- ;; We just read a list after a dot, which will be abbreviated out.
- (setq edebug-read-dotted-list nil)
- ;; Drop the corresponding offset pair.
- ;; That is, nconc the reverse of the rest of the offsets
- ;; with the cdr of last offset.
- (setcdr edebug-current-offset
- (nconc (nreverse (cdr (cdr edebug-current-offset)))
- (cdr (car (cdr edebug-current-offset))))))
-
- ;; Now append the point using nconc.
- (setq edebug-current-offset (nconc edebug-current-offset point))
- ;; Pop the stack.
- (setq edebug-offsets-stack (cdr edebug-offsets-stack)
- edebug-current-offset (car edebug-offsets-stack)))
-
- (defun edebug-ignore-offset ()
- ;; Ignore the last created offset pair.
- (setcdr edebug-current-offset (cdr (cdr edebug-current-offset))))
-
- (def-edebug-spec edebug-storing-offsets (form body))
- (put 'edebug-storing-offsets 'lisp-indent-hook 1)
-
- (defmacro edebug-storing-offsets (point &rest body)
- (` (unwind-protect
- (progn
- (edebug-store-before-offset (, point))
- (,@ body))
- (edebug-store-after-offset (point)))))
-
-
- ;;; Reader for Emacs Lisp.
-
- ;; Uses edebug-next-token-class (and edebug-skip-whitespace) above.
-
- (defconst edebug-read-alist
- '((symbol . edebug-read-symbol)
- (lparen . edebug-read-list)
- (string . edebug-read-string)
- (quote . edebug-read-quote)
- (backquote . edebug-read-backquote)
- (comma . edebug-read-comma)
- (lbracket . edebug-read-vector)
- (hash . edebug-read-function)
- ))
-
- (defun edebug-read-storing-offsets (stream)
- (let ((class (edebug-next-token-class))
- func
- edebug-read-dotted-list) ; see edebug-store-after-offset
- (edebug-storing-offsets (point)
- (if (setq func (assq class edebug-read-alist))
- (funcall (cdr func) stream)
- ;; anything else, just read it.
- (edebug-original-read stream))
- )))
-
- (defun edebug-read-symbol (stream)
- (prog1
- (edebug-original-read stream)
- ;; loses for escaped chars
- (if (not (eq (aref edebug-read-syntax-table
- (preceding-char)) 'symbol))
- (forward-char -1))))
-
- (defun edebug-read-string (stream)
- (prog1
- (edebug-original-read stream)
- (if (/= (preceding-char) ?\")
- (forward-char -1))))
-
- (defun edebug-read-quote (stream)
- ;; Turn 'thing into (quote thing)
- (forward-char 1)
- (list
- (edebug-storing-offsets (point) 'quote)
- (edebug-read-storing-offsets stream)))
-
- (defun edebug-read-backquote (stream)
- ;; Turn `thing into (\` thing)
- (let ((opoint (point)))
- (forward-char 1)
- ;; Generate the same structure of offsets we would have
- ;; if the resulting list appeared verbatim in the input text.
- (edebug-storing-offsets opoint
- (list
- (edebug-storing-offsets opoint '\`)
- (edebug-read-storing-offsets stream)))))
-
- (defvar edebug-read-backquote-new nil
- "Non-nil if reading the inside of a new-style backquote with no parens around it.
- Value of nil means reading the inside of an old-style backquote construct
- which is surrounded by an extra set of parentheses.
- This controls how we read comma constructs.")
-
- (defun edebug-read-comma (stream)
- ;; Turn ,thing into (\, thing). Handle ,@ and ,. also.
- (let ((opoint (point)))
- (forward-char 1)
- (let ((symbol '\,))
- (cond ((eq (following-char) ?\.)
- (setq symbol '\,\.)
- (forward-char 1))
- ((eq (following-char) ?\@)
- (setq symbol '\,@)
- (forward-char 1)))
- ;; Generate the same structure of offsets we would have
- ;; if the resulting list appeared verbatim in the input text.
- (if edebug-read-backquote-new
- (list
- (edebug-storing-offsets opoint symbol)
- (edebug-read-storing-offsets stream))
- (edebug-storing-offsets opoint symbol)))))
-
- (defun edebug-read-function (stream)
- ;; Turn #'thing into (function thing)
- (forward-char 1)
- (if (/= ?\' (following-char)) (edebug-syntax-error "Bad char"))
- (forward-char 1)
- (list
- (edebug-storing-offsets (point)
- (if (featurep 'cl) 'function* 'function))
- (edebug-read-storing-offsets stream)))
-
- (defun edebug-read-list (stream)
- (forward-char 1) ; skip \(
- (prog1
- (let ((elements))
- (while (not (memq (edebug-next-token-class) '(rparen dot)))
- (if (eq (edebug-next-token-class) 'backquote)
- (let ((edebug-read-backquote-new (not (null elements)))
- (opoint (point)))
- (if edebug-read-backquote-new
- (setq elements (cons (edebug-read-backquote stream) elements))
- (forward-char 1) ; Skip backquote.
- ;; Call edebug-storing-offsets here so that we
- ;; produce the same offsets we would have had
- ;; if the backquote were an ordinary symbol.
- (setq elements (cons (edebug-storing-offsets opoint '\`)
- elements))))
- (setq elements (cons (edebug-read-storing-offsets stream) elements))))
- (setq elements (nreverse elements))
- (if (eq 'dot (edebug-next-token-class))
- (let (dotted-form)
- (forward-char 1) ; skip \.
- (setq dotted-form (edebug-read-storing-offsets stream))
- elements (nconc elements dotted-form)
- (if (not (eq (edebug-next-token-class) 'rparen))
- (edebug-syntax-error "Expected `)'"))
- (setq edebug-read-dotted-list (listp dotted-form))
- ))
- elements)
- (forward-char 1) ; skip \)
- ))
-
- (defun edebug-read-vector (stream)
- (forward-char 1) ; skip \[
- (prog1
- (let ((elements))
- (while (not (eq 'rbracket (edebug-next-token-class)))
- (setq elements (cons (edebug-read-storing-offsets stream) elements)))
- (apply 'vector (nreverse elements)))
- (forward-char 1) ; skip \]
- ))
-
- ;;; Cursors for traversal of list and vector elements with offsets.
-
- (defvar edebug-dotted-spec nil)
-
- (defun edebug-new-cursor (expressions offsets)
- ;; Return a new cursor for EXPRESSIONS with OFFSETS.
- (if (vectorp expressions)
- (setq expressions (append expressions nil)))
- (cons expressions offsets))
-
- (defsubst edebug-set-cursor (cursor expressions offsets)
- ;; Set the CURSOR's EXPRESSIONS and OFFSETS to the given.
- ;; Return the cursor.
- (setcar cursor expressions)
- (setcdr cursor offsets)
- cursor)
-
- '(defun edebug-copy-cursor (cursor)
- ;; Copy the cursor using the same object and offsets.
- (cons (car cursor) (cdr cursor)))
-
- (defsubst edebug-cursor-expressions (cursor)
- (car cursor))
- (defsubst edebug-cursor-offsets (cursor)
- (cdr cursor))
-
- (defsubst edebug-empty-cursor (cursor)
- ;; Return non-nil if CURSOR is empty - meaning no more elements.
- (null (car cursor)))
-
- (defsubst edebug-top-element (cursor)
- ;; Return the top element at the cursor.
- ;; Assumes not empty.
- (car (car cursor)))
-
- (defun edebug-top-element-required (cursor &rest error)
- ;; Check if a dotted form is required.
- (if edebug-dotted-spec (edebug-no-match cursor "Dot expected."))
- ;; Check if there is at least one more argument.
- (if (edebug-empty-cursor cursor) (apply 'edebug-no-match cursor error))
- ;; Return that top element.
- (edebug-top-element cursor))
-
- (defsubst edebug-top-offset (cursor)
- ;; Return the top offset pair corresponding to the top element.
- (car (cdr cursor)))
-
- (defun edebug-move-cursor (cursor)
- ;; Advance and return the cursor to the next element and offset.
- ;; throw no-match if empty before moving.
- ;; This is a violation of the cursor encapsulation, but
- ;; there is plenty of that going on while matching.
- ;; The following test should always fail.
- (if (edebug-empty-cursor cursor)
- (edebug-no-match cursor "Not enough arguments."))
- (setcar cursor (cdr (car cursor)))
- (setcdr cursor (cdr (cdr cursor)))
- cursor)
-
-
- (defun edebug-before-offset (cursor)
- ;; Return the before offset of the cursor.
- ;; If there is nothing left in the offsets,
- ;; return one less than the offset itself,
- ;; which is the after offset for a list.
- (let ((offset (edebug-cursor-offsets cursor)))
- (if (consp offset)
- (car (car offset))
- (1- offset))))
-
- (defun edebug-after-offset (cursor)
- ;; Return the after offset of the cursor object.
- (let ((offset (edebug-top-offset cursor)))
- (while (consp offset)
- (setq offset (cdr offset)))
- offset))
-
- ;;; The Parser
-
- ;; The top level function for parsing forms is
- ;; edebug-read-and-maybe-wrap-form; it calls all the rest. It checks the
- ;; syntax a bit and leaves point at any error it finds, but otherwise
- ;; should appear to work like eval-defun.
-
- ;; The basic plan is to surround each expression with a call to
- ;; the edebug debugger together with indexes into a table of positions of
- ;; all expressions. Thus an expression "exp" becomes:
-
- ;; (edebug-after (edebug-before 1) 2 exp)
-
- ;; When this is evaluated, first point is moved to the beginning of
- ;; exp at offset 1 of the current function. The expression is
- ;; evaluated, which may cause more edebug calls, and then point is
- ;; moved to offset 2 after the end of exp.
-
- ;; The highest level expressions of the function are wrapped in a call to
- ;; edebug-enter, which supplies the function name and the actual
- ;; arguments to the function. See functions edebug-enter, edebug-before,
- ;; and edebug-after for more details.
-
- ;; Dynamically bound vars, left unbound, but globally declared.
- ;; This is to quiet the byte compiler.
-
- ;; Window data of the highest definition being wrapped.
- ;; This data is shared by all embedded definitions.
- (defvar edebug-top-window-data)
-
- (defvar edebug-&optional)
- (defvar edebug-&rest)
- (defvar edebug-gate nil) ;; whether no-match forces an error.
-
- (defconst edebug-def-name nil) ; name of definition, used by interactive-form
- (defconst edebug-old-def-name nil) ; previous name of containing definition.
-
- (defconst edebug-error-point nil)
- (defconst edebug-best-error nil)
-
-
- (defun edebug-read-and-maybe-wrap-form ()
- ;; Read a form and wrap it with edebug calls, if the conditions are right.
- ;; Here we just catch any no-match not caught below and signal an error.
-
- ;; Run the setup hook.
- (run-hooks 'edebug-setup-hook)
- (setq edebug-setup-hook nil)
-
- (let (result
- edebug-top-window-data
- edebug-def-name;; make sure it is locally nil
- ;; I don't like these here!!
- edebug-&optional
- edebug-&rest
- edebug-gate
- edebug-best-error
- edebug-error-point
- no-match
- ;; Do this once here instead of several times.
- (max-lisp-eval-depth (+ 800 max-lisp-eval-depth))
- (max-specpdl-size (+ 2000 max-specpdl-size)))
- (setq no-match
- (catch 'no-match
- (setq result (edebug-read-and-maybe-wrap-form1))
- nil))
- (if no-match
- (apply 'edebug-syntax-error no-match))
- result))
-
-
- (defun edebug-read-and-maybe-wrap-form1 ()
- (let (spec
- def-kind
- defining-form-p
- def-name
- ;; These offset things don't belong here, but to support recursive
- ;; calls to edebug-read, they need to be here.
- edebug-offsets
- edebug-offsets-stack
- edebug-current-offset ; reset to nil
- )
- (save-excursion
- (if (and (eq 'lparen (edebug-next-token-class))
- (eq 'symbol (progn (forward-char 1) (edebug-next-token-class))))
- ;; Find out if this is a defining form from first symbol
- (setq def-kind (edebug-original-read (current-buffer))
- spec (and (symbolp def-kind) (get-edebug-spec def-kind))
- defining-form-p (and (listp spec)
- (eq '&define (car spec)))
- ;; This is incorrect in general!! But OK most of the time.
- def-name (if (and defining-form-p
- (eq 'name (car (cdr spec)))
- (eq 'symbol (edebug-next-token-class)))
- (edebug-original-read (current-buffer))))))
- ;;;(message "all defs: %s all forms: %s" edebug-all-defs edebug-all-forms)
- (cond
- (defining-form-p
- (if (or edebug-all-defs edebug-all-forms)
- ;; If it is a defining form and we are edebugging defs,
- ;; then let edebug-list-form start it.
- (let ((cursor (edebug-new-cursor
- (list (edebug-read-storing-offsets (current-buffer)))
- (list edebug-offsets))))
- (car
- (edebug-make-form-wrapper
- cursor
- (edebug-before-offset cursor)
- (1- (edebug-after-offset cursor))
- (list (cons (symbol-name def-kind) (cdr spec))))))
-
- ;; Not edebugging this form, so reset the symbol's edebug
- ;; property to be just a marker at the definition's source code.
- ;; This only works for defs with simple names.
- (put def-name 'edebug (point-marker))
- ;; Also nil out dependent defs.
- '(mapcar (function
- (lambda (def)
- (put def-name 'edebug nil)))
- (get def-name 'edebug-dependents))
- (edebug-read-sexp)))
-
- ;; If all forms are being edebugged, explicitly wrap it.
- (edebug-all-forms
- (let ((cursor (edebug-new-cursor
- (list (edebug-read-storing-offsets (current-buffer)))
- (list edebug-offsets))))
- (edebug-make-form-wrapper
- cursor
- (edebug-before-offset cursor)
- (edebug-after-offset cursor)
- nil)))
-
- ;; Not a defining form, and not edebugging.
- (t (edebug-read-sexp)))
- ))
-
-
- (defvar edebug-def-args) ; args of defining form.
- (defvar edebug-def-interactive) ; is it an emacs interactive function?
- (defvar edebug-inside-func) ;; whether code is inside function context.
- ;; Currently def-form sets this to nil; def-body sets it to t.
-
- (defun edebug-interactive-p-name ()
- ;; Return a unique symbol for the variable used to store the
- ;; status of interactive-p for this function.
- (intern (format "edebug-%s-interactive-p" edebug-def-name)))
-
-
- (defun edebug-wrap-def-body (forms)
- "Wrap the FORMS of a definition body."
- (if edebug-def-interactive
- (` (let (((, (edebug-interactive-p-name))
- (interactive-p)))
- (, (edebug-make-enter-wrapper forms))))
- (edebug-make-enter-wrapper forms)))
-
-
- (defun edebug-make-enter-wrapper (forms)
- ;; Generate the enter wrapper for some forms of a definition.
- ;; This is not to be used for the body of other forms, e.g. `while',
- ;; since it wraps the list of forms with a call to `edebug-enter'.
- ;; Uses the dynamically bound vars edebug-def-name and edebug-def-args.
- ;; Do this after parsing since that may find a name.
- (setq edebug-def-name
- (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon")))
- (` (edebug-enter
- (quote (, edebug-def-name))
- (, (if edebug-inside-func
- (` (list (,@
- ;; Doesn't work with more than one def-body!!
- ;; But the list will just be reversed.
- (nreverse edebug-def-args))))
- 'nil))
- (function (lambda () (,@ forms)))
- )))
-
-
- (defvar edebug-form-begin-marker) ; the mark for def being instrumented
-
- (defvar edebug-offset-index) ; the next available offset index.
- (defvar edebug-offset-list) ; the list of offset positions.
-
- (defun edebug-inc-offset (offset)
- ;; modifies edebug-offset-index and edebug-offset-list
- ;; accesses edebug-func-marc and buffer point
- (prog1
- edebug-offset-index
- (setq edebug-offset-list (cons (- offset edebug-form-begin-marker)
- edebug-offset-list)
- edebug-offset-index (1+ edebug-offset-index))))
-
-
- (defun edebug-make-before-and-after-form (before-index form after-index)
- ;; Return the edebug form for the current function at offset BEFORE-INDEX
- ;; given FORM. Looks like:
- ;; (edebug-after (edebug-before BEFORE-INDEX) AFTER-INDEX FORM)
- ;; Also increment the offset index for subsequent use.
- ;; if (not edebug-stop-before-symbols) and form is a symbol,
- ;; then don't call edebug-before.
- (list 'edebug-after
- (list 'edebug-before before-index)
- after-index form))
-
- (defun edebug-make-after-form (form after-index)
- ;; Like edebug-make-before-and-after-form, but only after.
- (list 'edebug-after 0 after-index form))
-
-
- (defun edebug-unwrap (sexp)
- "Return the unwrapped SEXP or return it as is if it is not wrapped.
- The SEXP might be the result of wrapping a body, which is a list of
- expressions; a `progn' form will be returned enclosing these forms."
- (if (consp sexp)
- (cond
- ((eq 'edebug-after (car sexp))
- (nth 3 sexp))
- ((eq 'edebug-enter (car sexp))
- (let ((forms (nthcdr 2 (nth 1 (nth 3 sexp)))))
- (if (> (length forms) 1)
- (cons 'progn forms) ;; could return (values forms) instead.
- (car forms))))
- (t sexp);; otherwise it is not wrapped, so just return it.
- )
- sexp))
-
- (defun edebug-unwrap* (sexp)
- "Return the sexp recursively unwrapped."
- (let ((new-sexp (edebug-unwrap sexp)))
- (while (not (eq sexp new-sexp))
- (setq sexp new-sexp
- new-sexp (edebug-unwrap sexp)))
- (if (consp new-sexp)
- (mapcar 'edebug-unwrap* new-sexp)
- new-sexp)))
-
-
- (defun edebug-defining-form (cursor form-begin form-end speclist)
- ;; Process the defining form, starting outside the form.
- ;; The speclist is a generated list spec that looks like:
- ;; (("def-symbol" defining-form-spec-sans-&define))
- ;; Skip the first offset.
- (edebug-set-cursor cursor (edebug-cursor-expressions cursor)
- (cdr (edebug-cursor-offsets cursor)))
- (edebug-make-form-wrapper
- cursor
- form-begin (1- form-end)
- speclist))
-
- (defun edebug-make-form-wrapper (cursor form-begin form-end
- &optional speclist)
- ;; Wrap a form, usually a defining form, but any evaluated one.
- ;; If speclist is non-nil, this is being called by edebug-defining-form.
- ;; Otherwise it is being called from edebug-read-and-maybe-wrap-form1.
- ;; This is a hack, but I havent figured out a simpler way yet.
- (let* ((form-data-entry (edebug-get-form-data-entry form-begin form-end))
- ;; Set this marker before parsing.
- (edebug-form-begin-marker
- (if form-data-entry
- (edebug-form-data-begin form-data-entry)
- ;; Buffer must be current-buffer for this to work:
- (set-marker (make-marker) form-begin))))
-
- (let (edebug-offset-list
- (edebug-offset-index 0)
- result
- ;; For definitions.
- ;; (edebug-containing-def-name edebug-def-name)
- ;; Get name from form-data, if any.
- (edebug-old-def-name (edebug-form-data-name form-data-entry))
- edebug-def-name
- edebug-def-args
- edebug-def-interactive
- edebug-inside-func;; whether wrapped code executes inside a function.
- )
-
- (setq result
- (if speclist
- (edebug-match cursor speclist)
-
- ;; else wrap as an enter-form.
- (edebug-make-enter-wrapper (list (edebug-form cursor)))))
-
- ;; Set the name here if it was not set by edebug-make-enter-wrapper.
- (setq edebug-def-name
- (or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon")))
-
- ;; Add this def as a dependent of containing def. Buggy.
- '(if (and edebug-containing-def-name
- (not (get edebug-containing-def-name 'edebug-dependents)))
- (put edebug-containing-def-name 'edebug-dependents
- (cons edebug-def-name
- (get edebug-containing-def-name
- 'edebug-dependents))))
-
- ;; Create a form-data-entry or modify existing entry's markers.
- ;; In the latter case, pointers to the entry remain eq.
- (if (not form-data-entry)
- (setq form-data-entry
- (edebug-make-form-data-entry
- edebug-def-name
- edebug-form-begin-marker
- ;; Buffer must be current-buffer.
- (set-marker (make-marker) form-end)
- ))
- (edebug-set-form-data-entry
- form-data-entry edebug-def-name ;; in case name is changed
- form-begin form-end))
-
- ;; (message "defining: %s" edebug-def-name) (sit-for 2)
- (edebug-make-top-form-data-entry form-data-entry)
- (message "Edebug: %s" edebug-def-name)
- ;;(debug edebug-def-name)
-
- ;; Destructively reverse edebug-offset-list and make vector from it.
- (setq edebug-offset-list (vconcat (nreverse edebug-offset-list)))
-
- ;; Side effects on the property list of edebug-def-name.
- (edebug-clear-frequency-count edebug-def-name)
- (edebug-clear-coverage edebug-def-name)
-
- ;; Set up the initial window data.
- (if (not edebug-top-window-data) ;; if not already set, do it now.
- (let ((window ;; Find the best window for this buffer.
- (or (get-buffer-window (current-buffer))
- (selected-window))))
- (setq edebug-top-window-data
- (cons window (window-start window)))))
-
- ;; Store the edebug data in symbol's property list.
- (put edebug-def-name 'edebug
- ;; A struct or vector would be better here!!
- (list edebug-form-begin-marker
- nil ; clear breakpoints
- edebug-offset-list
- edebug-top-window-data
- ))
- result
- )))
-
-
- (defun edebug-clear-frequency-count (name)
- ;; Create initial frequency count vector.
- ;; For each stop point, the counter is incremented each time it is visited.
- (put name 'edebug-freq-count
- (make-vector (length edebug-offset-list) 0)))
-
-
- (defun edebug-clear-coverage (name)
- ;; Create initial coverage vector.
- ;; Only need one per expression, but it is simpler to use stop points.
- (put name 'edebug-coverage
- (make-vector (length edebug-offset-list) 'unknown)))
-
-
- (defun edebug-form (cursor)
- ;; Return the instrumented form for the following form.
- ;; Add the point offsets to the edebug-offset-list for the form.
- (let* ((form (edebug-top-element-required cursor "Expected form"))
- (offset (edebug-top-offset cursor)))
- (prog1
- (cond
- ((consp form)
- ;; The first offset for a list form is for the list form itself.
- (if (eq 'quote (car form))
- form
- (let* ((head (car form))
- (spec (and (symbolp head) (get-edebug-spec head)))
- (new-cursor (edebug-new-cursor form offset)))
- ;; Find out if this is a defining form from first symbol.
- ;; An indirect spec would not work here, yet.
- (if (and (consp spec) (eq '&define (car spec)))
- (edebug-defining-form
- new-cursor
- (car offset);; before the form
- (edebug-after-offset cursor)
- (cons (symbol-name head) (cdr spec)))
- ;; Wrap a regular form.
- (edebug-make-before-and-after-form
- (edebug-inc-offset (car offset))
- (edebug-list-form new-cursor)
- ;; After processing the list form, the new-cursor is left
- ;; with the offset after the form.
- (edebug-inc-offset (edebug-cursor-offsets new-cursor))))
- )))
-
- ((symbolp form)
- (cond
- ;; Check for constant symbols that don't get wrapped.
- ((or (memq form '(t nil))
- (and (fboundp 'edebug-keywordp) (edebug-keywordp form)))
- form)
-
- ;; This option may go away.
- (edebug-stop-before-symbols
- (edebug-make-before-and-after-form
- (edebug-inc-offset (car offset))
- form
- (edebug-inc-offset (cdr offset))
- ))
-
- (t ;; just a variable
- (edebug-make-after-form form (edebug-inc-offset (cdr offset))))))
-
- ;; Anything else is self-evaluating.
- (t form))
- (edebug-move-cursor cursor))))
-
-
- (defsubst edebug-forms (cursor) (edebug-match cursor '(&rest form)))
- (defsubst edebug-sexps (cursor) (edebug-match cursor '(&rest sexp)))
-
- (defsubst edebug-list-form-args (head cursor)
- ;; Process the arguments of a list form given that head of form is a symbol.
- ;; Helper for edebug-list-form
- (let ((spec (get-edebug-spec head)))
- (cond
- (spec
- (cond
- ((consp spec)
- ;; It is a speclist.
- (let (edebug-best-error
- edebug-error-point);; This may not be needed.
- (edebug-match-sublist cursor spec)))
- ((eq t spec) (edebug-forms cursor))
- ((eq 0 spec) (edebug-sexps cursor))
- ((symbolp spec) (funcall spec cursor));; Not used by edebug,
- ; but leave it in for compatibility.
- ))
- ;; No edebug-form-spec provided.
- ((edebug-macrop head)
- (if edebug-eval-macro-args
- (edebug-forms cursor)
- (edebug-sexps cursor)))
- (t ;; Otherwise it is a function call.
- (edebug-forms cursor)))))
-
-
- (defun edebug-list-form (cursor)
- ;; Return an instrumented form built from the list form.
- ;; The after offset will be left in the cursor after processing the form.
- (let ((head (edebug-top-element-required cursor "Expected elements"))
- ;; Prevent backtracking whenever instrumenting.
- (edebug-gate t)
- ;; A list form is never optional because it matches anything.
- (edebug-&optional nil)
- (edebug-&rest nil))
- ;; Skip the first offset.
- (edebug-set-cursor cursor (edebug-cursor-expressions cursor)
- (cdr (edebug-cursor-offsets cursor)))
- (cond
- ((null head) nil) ; () is legal.
-
- ((symbolp head)
- (cond
- ((null head)
- (edebug-syntax-error "nil head"))
- ((eq head 'interactive-p)
- ;; Special case: replace (interactive-p) with variable
- (setq edebug-def-interactive 'check-it)
- (edebug-move-cursor cursor)
- (edebug-interactive-p-name))
- (t
- (cons head (edebug-list-form-args
- head (edebug-move-cursor cursor))))))
-
- ((consp head)
- (if (and (listp head) (eq (car head) ',))
- (edebug-match cursor '(("," def-form) body))
- ;; Process anonymous function and args.
- ;; This assumes no anonymous macros.
- (edebug-match-specs cursor '(lambda-expr body) 'edebug-match-specs)))
-
- (t (edebug-syntax-error
- "Head of list form must be a symbol or lambda expression.")))
- ))
-
- ;;; Matching of specs.
-
- (defvar edebug-after-dotted-spec nil)
-
- (defvar edebug-matching-depth 0) ;; initial value
- (defconst edebug-max-depth 150) ;; maximum number of matching recursions.
-
-
- ;;; Failure to match
-
- ;; This throws to no-match, if there are higher alternatives.
- ;; Otherwise it signals an error. The place of the error is found
- ;; with the two before- and after-offset functions.
-
- (defun edebug-no-match (cursor &rest edebug-args)
- ;; Throw a no-match, or signal an error immediately if gate is active.
- ;; Remember this point in case we need to report this error.
- (setq edebug-error-point (or edebug-error-point
- (edebug-before-offset cursor))
- edebug-best-error (or edebug-best-error edebug-args))
- (if (and edebug-gate (not edebug-&optional))
- (progn
- (if edebug-error-point
- (goto-char edebug-error-point))
- (apply 'edebug-syntax-error edebug-args))
- (funcall 'throw 'no-match edebug-args)))
-
-
- (defun edebug-match (cursor specs)
- ;; Top level spec matching function.
- ;; Used also at each lower level of specs.
- (let (edebug-&optional
- edebug-&rest
- edebug-best-error
- edebug-error-point
- (edebug-gate edebug-gate) ;; locally bound to limit effect
- )
- (edebug-match-specs cursor specs 'edebug-match-specs)))
-
-
- (defun edebug-match-one-spec (cursor spec)
- ;; Match one spec, which is not a keyword &-spec.
- (cond
- ((symbolp spec) (edebug-match-symbol cursor spec))
- ((vectorp spec) (edebug-match cursor (append spec nil)))
- ((stringp spec) (edebug-match-string cursor spec))
- ((listp spec) (edebug-match-list cursor spec))
- ))
-
-
- (defun edebug-match-specs (cursor specs remainder-handler)
- ;; Append results of matching the list of specs.
- ;; The first spec is handled and the remainder-handler handles the rest.
- (let ((edebug-matching-depth
- (if (> edebug-matching-depth edebug-max-depth)
- (error "too deep - perhaps infinite loop in spec?")
- (1+ edebug-matching-depth))))
- (cond
- ((null specs) nil)
-
- ;; Is the spec dotted?
- ((atom specs)
- (let ((edebug-dotted-spec t));; Containing spec list was dotted.
- (edebug-match-specs cursor (list specs) remainder-handler)))
-
- ;; Is the form dotted?
- ((not (listp (edebug-cursor-expressions cursor)));; allow nil
- (if (not edebug-dotted-spec)
- (edebug-no-match cursor "Dotted spec required."))
- ;; Cancel dotted spec and dotted form.
- (let ((edebug-dotted-spec)
- (this-form (edebug-cursor-expressions cursor))
- (this-offset (edebug-cursor-offsets cursor)))
- ;; Wrap the form in a list, (by changing the cursor??)...
- (edebug-set-cursor cursor (list this-form) this-offset)
- ;; and process normally, then unwrap the result.
- (car (edebug-match-specs cursor specs remainder-handler))))
-
- (t;; Process normally.
- (let* ((spec (car specs))
- (rest)
- (first-char (and (symbolp spec) (aref (symbol-name spec) 0))))
- ;;(message "spec = %s first char = %s" spec first-char) (sit-for 1)
- (nconc
- (cond
- ((eq ?& first-char);; "&" symbols take all following specs.
- (funcall (get-edebug-spec spec) cursor (cdr specs)))
- ((eq ?: first-char);; ":" symbols take one following spec.
- (setq rest (cdr (cdr specs)))
- (funcall (get-edebug-spec spec) cursor (car (cdr specs))))
- (t;; Any other normal spec.
- (setq rest (cdr specs))
- (edebug-match-one-spec cursor spec)))
- (funcall remainder-handler cursor rest remainder-handler)))))))
-
-
- ;; Define specs for all the symbol specs with functions used to process them.
- ;; Perhaps we shouldn't be doing this with edebug-form-specs since the
- ;; user may want to define macros or functions with the same names.
- ;; We could use an internal obarray for these primitive specs.
-
- (mapcar
- (function (lambda (pair)
- (put (car pair) 'edebug-form-spec (cdr pair))))
- '((&optional . edebug-match-&optional)
- (&rest . edebug-match-&rest)
- (&or . edebug-match-&or)
- (form . edebug-match-form)
- (sexp . edebug-match-sexp)
- (body . edebug-match-body)
- (&define . edebug-match-&define)
- (name . edebug-match-name)
- (:name . edebug-match-colon-name)
- (arg . edebug-match-arg)
- (def-body . edebug-match-def-body)
- (def-form . edebug-match-def-form)
- ;; Less frequently used:
- ;; (function . edebug-match-function)
- (lambda-expr . edebug-match-lambda-expr)
- (¬ . edebug-match-¬)
- (&key . edebug-match-&key)
- (place . edebug-match-place)
- (gate . edebug-match-gate)
- ;; (nil . edebug-match-nil) not this one - special case it.
- ))
-
- (defun edebug-match-symbol (cursor symbol)
- ;; Match a symbol spec.
- (let* ((spec (get-edebug-spec symbol)))
- (cond
- (spec
- (if (consp spec)
- ;; It is an indirect spec.
- (edebug-match cursor spec)
- ;; Otherwise it should be the symbol name of a function.
- ;; There could be a bug here - maybe need to do edebug-match bindings.
- (funcall spec cursor)))
-
- ((null symbol) ;; special case this.
- (edebug-match-nil cursor))
-
- ((fboundp symbol) ; is it a predicate?
- (let ((sexp (edebug-top-element-required cursor "Expected" symbol)))
- ;; Special case for edebug-`.
- (if (and (listp sexp) (eq (car sexp) ',))
- (edebug-match cursor '(("," def-form)))
- (if (not (funcall symbol sexp))
- (edebug-no-match cursor symbol "failed"))
- (edebug-move-cursor cursor)
- (list sexp))))
- (t (error "%s is not a form-spec or function" symbol))
- )))
-
-
- (defun edebug-match-sexp (cursor)
- (list (prog1 (edebug-top-element-required cursor "Expected sexp")
- (edebug-move-cursor cursor))))
-
- (defun edebug-match-form (cursor)
- (list (edebug-form cursor)))
-
- (defalias 'edebug-match-place 'edebug-match-form)
- ;; Currently identical to edebug-match-form.
- ;; This is for common lisp setf-style place arguments.
-
- (defsubst edebug-match-body (cursor) (edebug-forms cursor))
-
- (defun edebug-match-&optional (cursor specs)
- ;; Keep matching until one spec fails.
- (edebug-&optional-wrapper cursor specs 'edebug-&optional-wrapper))
-
- (defun edebug-&optional-wrapper (cursor specs remainder-handler)
- (let (result
- (edebug-&optional specs)
- (edebug-gate nil)
- (this-form (edebug-cursor-expressions cursor))
- (this-offset (edebug-cursor-offsets cursor)))
- (if (null (catch 'no-match
- (setq result
- (edebug-match-specs cursor specs remainder-handler))
- ;; Returning nil means no no-match was thrown.
- nil))
- result
- ;; no-match, but don't fail; just reset cursor and return nil.
- (edebug-set-cursor cursor this-form this-offset)
- nil)))
-
-
- (defun edebug-&rest-wrapper (cursor specs remainder-handler)
- (if (null specs) (setq specs edebug-&rest))
- ;; Reuse the &optional handler with this as the remainder handler.
- (edebug-&optional-wrapper cursor specs remainder-handler))
-
- (defun edebug-match-&rest (cursor specs)
- ;; Repeatedly use specs until failure.
- (let ((edebug-&rest specs) ;; remember these
- edebug-best-error
- edebug-error-point)
- (edebug-&rest-wrapper cursor specs 'edebug-&rest-wrapper)))
-
-
- (defun edebug-match-&or (cursor specs)
- ;; Keep matching until one spec succeeds, and return its results.
- ;; If none match, fail.
- ;; This needs to be optimized since most specs spend time here.
- (let ((original-specs specs)
- (this-form (edebug-cursor-expressions cursor))
- (this-offset (edebug-cursor-offsets cursor)))
- (catch 'matched
- (while specs
- (catch 'no-match
- (throw 'matched
- (let (edebug-gate ;; only while matching each spec
- edebug-best-error
- edebug-error-point)
- ;; Doesn't support e.g. &or symbolp &rest form
- (edebug-match-one-spec cursor (car specs)))))
- ;; Match failed, so reset and try again.
- (setq specs (cdr specs))
- ;; Reset the cursor for the next match.
- (edebug-set-cursor cursor this-form this-offset))
- ;; All failed.
- (apply 'edebug-no-match cursor "Expected one of" original-specs))
- ))
-
-
- (defun edebug-match-¬ (cursor specs)
- ;; If any specs match, then fail
- (if (null (catch 'no-match
- (let ((edebug-gate nil))
- (save-excursion
- (edebug-match-&or cursor specs)))
- nil))
- ;; This means something matched, so it is a no match.
- (edebug-no-match cursor "Unexpected"))
- ;; This means nothing matched, so it is OK.
- nil) ;; So, return nothing
-
-
- (def-edebug-spec &key edebug-match-&key)
-
- (defun edebug-match-&key (cursor specs)
- ;; Following specs must look like (<name> <spec>) ...
- ;; where <name> is the name of a keyword, and spec is its spec.
- ;; This really doesn't save much over the expanded form and takes time.
- (edebug-match-&rest
- cursor
- (cons '&or
- (mapcar (function (lambda (pair)
- (vector (format ":%s" (car pair))
- (car (cdr pair)))))
- specs))))
-
-
- (defun edebug-match-gate (cursor)
- ;; Simply set the gate to prevent backtracking at this level.
- (setq edebug-gate t)
- nil)
-
-
- (defun edebug-match-list (cursor specs)
- ;; The spec is a list, but what kind of list, and what context?
- (if edebug-dotted-spec
- ;; After dotted spec but form did not contain dot,
- ;; so match list spec elements as if spliced in.
- (prog1
- (let ((edebug-dotted-spec))
- (edebug-match-specs cursor specs 'edebug-match-specs))
- ;; If it matched, really clear the dotted-spec flag.
- (setq edebug-dotted-spec nil))
- (let ((spec (car specs))
- (form (edebug-top-element-required cursor "Expected" specs)))
- (cond
- ((eq 'quote spec)
- (let ((spec (car (cdr specs))))
- (cond
- ((symbolp spec)
- ;; Special case: spec quotes a symbol to match.
- ;; Change in future. Use "..." instead.
- (if (not (eq spec form))
- (edebug-no-match cursor "Expected" spec))
- (edebug-move-cursor cursor)
- (setq edebug-gate t)
- form)
- (t
- (error "Bad spec: %s" specs)))))
-
- ((listp form)
- (prog1
- (list (edebug-match-sublist
- ;; First offset is for the list form itself.
- ;; Treat nil as empty list.
- (edebug-new-cursor form (cdr (edebug-top-offset cursor)))
- specs))
- (edebug-move-cursor cursor)))
-
- ((and (eq 'vector spec) (vectorp form))
- ;; Special case: match a vector with the specs.
- (let ((result (edebug-match-sublist
- (edebug-new-cursor
- form (cdr (edebug-top-offset cursor)))
- (cdr specs))))
- (edebug-move-cursor cursor)
- (list (apply 'vector result))))
-
- (t (edebug-no-match cursor "Expected" specs)))
- )))
-
-
- (defun edebug-match-sublist (cursor specs)
- ;; Match a sublist of specs.
- (let (edebug-&optional
- ;;edebug-best-error
- ;;edebug-error-point
- )
- (prog1
- ;; match with edebug-match-specs so edebug-best-error is not bound.
- (edebug-match-specs cursor specs 'edebug-match-specs)
- (if (not (edebug-empty-cursor cursor))
- (if edebug-best-error
- (apply 'edebug-no-match cursor edebug-best-error)
- ;; A failed &rest or &optional spec may leave some args.
- (edebug-no-match cursor "Failed matching" specs)
- )))))
-
-
- (defun edebug-match-string (cursor spec)
- (let ((sexp (edebug-top-element-required cursor "Expected" spec)))
- (if (not (eq (intern spec) sexp))
- (edebug-no-match cursor "Expected" spec)
- ;; Since it matched, failure means immediate error, unless &optional.
- (setq edebug-gate t)
- (edebug-move-cursor cursor)
- (list sexp)
- )))
-
- (defun edebug-match-nil (cursor)
- ;; There must be nothing left to match a nil.
- (if (not (edebug-empty-cursor cursor))
- (edebug-no-match cursor "Unmatched argument(s)")
- nil))
-
-
- (defun edebug-match-function (cursor)
- (error "Use function-form instead of function in edebug spec"))
-
- (defun edebug-match-&define (cursor specs)
- ;; Match a defining form.
- ;; Normally, &define is interpreted specially other places.
- ;; This should only be called inside of a spec list to match the remainder
- ;; of the current list. e.g. ("lambda" &define args def-body)
- (edebug-make-form-wrapper
- cursor
- (edebug-before-offset cursor)
- ;; Find the last offset in the list.
- (let ((offsets (edebug-cursor-offsets cursor)))
- (while (consp offsets) (setq offsets (cdr offsets)))
- offsets)
- specs))
-
- (defun edebug-match-lambda-expr (cursor)
- ;; The expression must be a function.
- ;; This will match any list form that begins with a symbol
- ;; that has an edebug-form-spec beginning with &define. In
- ;; practice, only lambda expressions should be used.
- ;; I could add a &lambda specification to avoid confusion.
- (let* ((sexp (edebug-top-element-required
- cursor "Expected lambda expression"))
- (offset (edebug-top-offset cursor))
- (head (and (consp sexp) (car sexp)))
- (spec (and (symbolp head) (get-edebug-spec head)))
- (edebug-inside-func nil))
- ;; Find out if this is a defining form from first symbol.
- (if (and (consp spec) (eq '&define (car spec)))
- (prog1
- (list
- (edebug-defining-form
- (edebug-new-cursor sexp offset)
- (car offset);; before the sexp
- (edebug-after-offset cursor)
- (cons (symbol-name head) (cdr spec))))
- (edebug-move-cursor cursor))
- (edebug-no-match cursor "Expected lambda expression")
- )))
-
-
- (defun edebug-match-name (cursor)
- ;; Set the edebug-def-name bound in edebug-defining-form.
- (let ((name (edebug-top-element-required cursor "Expected name")))
- ;; Maybe strings and numbers could be used.
- (if (not (symbolp name))
- (edebug-no-match cursor "Symbol expected for name of definition"))
- (setq edebug-def-name
- (if edebug-def-name
- ;; Construct a new name by appending to previous name.
- (intern (format "%s@%s" edebug-def-name name))
- name))
- (edebug-move-cursor cursor)
- (list name)))
-
- (defun edebug-match-colon-name (cursor spec)
- ;; Set the edebug-def-name to the spec.
- (setq edebug-def-name
- (if edebug-def-name
- ;; Construct a new name by appending to previous name.
- (intern (format "%s@%s" edebug-def-name spec))
- spec))
- nil)
-
- (defun edebug-match-arg (cursor)
- ;; set the def-args bound in edebug-defining-form
- (let ((edebug-arg (edebug-top-element-required cursor "Expected arg")))
- (if (or (not (symbolp edebug-arg))
- (edebug-lambda-list-keywordp edebug-arg))
- (edebug-no-match cursor "Bad argument:" edebug-arg))
- (edebug-move-cursor cursor)
- (setq edebug-def-args (cons edebug-arg edebug-def-args))
- (list edebug-arg)))
-
- (defun edebug-match-def-form (cursor)
- ;; Like form but the form is wrapped in edebug-enter form.
- ;; The form is assumed to be executing outside of the function context.
- ;; This is a hack for now, since a def-form might execute inside as well.
- ;; Not to be used otherwise.
- (let ((edebug-inside-func nil))
- (list (edebug-make-enter-wrapper (list (edebug-form cursor))))))
-
- (defun edebug-match-def-body (cursor)
- ;; Like body but body is wrapped in edebug-enter form.
- ;; The body is assumed to be executing inside of the function context.
- ;; Not to be used otherwise.
- (let ((edebug-inside-func t))
- (list (edebug-wrap-def-body (edebug-forms cursor)))))
-
-
- ;;;; Edebug Form Specs
- ;;; ==========================================================
- ;;; See cl-specs.el for common lisp specs.
-
- ;;;;* Spec for def-edebug-spec
- ;;; Out of date.
-
- (defun edebug-spec-p (object)
- "Return non-nil if OBJECT is a symbol with an edebug-form-spec property."
- (and (symbolp object)
- (get object 'edebug-form-spec)))
-
- (def-edebug-spec def-edebug-spec
- ;; Top level is different from lower levels.
- (&define :name edebug-spec name
- &or "nil" edebug-spec-p "t" "0" (&rest edebug-spec)))
-
- (def-edebug-spec edebug-spec-list
- ;; A list must have something in it, or it is nil, a symbolp
- ((edebug-spec . [&or nil edebug-spec])))
-
- (def-edebug-spec edebug-spec
- (&or
- (vector &rest edebug-spec) ; matches a vector
- ("vector" &rest edebug-spec) ; matches a vector spec
- ("quote" symbolp)
- edebug-spec-list
- stringp
- [edebug-lambda-list-keywordp &rest edebug-spec]
- ;; [edebug-keywordp gate edebug-spec] ;; need edebug-keywordp for this.
- edebug-spec-p ;; Including all the special ones e.g. form.
- symbolp;; a predicate
- ))
-
-
- ;;;* Emacs special forms and some functions.
-
- ;; quote expects only one argument, although it allows any number.
- (def-edebug-spec quote sexp)
-
- ;; The standard defining forms.
- (def-edebug-spec defconst defvar)
- (def-edebug-spec defvar (symbolp &optional form stringp))
-
- (def-edebug-spec defun
- (&define name lambda-list
- [&optional stringp]
- [&optional ("interactive" interactive)]
- def-body))
- (def-edebug-spec defmacro
- (&define name lambda-list def-body))
-
- (def-edebug-spec arglist lambda-list) ;; deprecated - use lambda-list.
-
- (def-edebug-spec lambda-list
- (([&rest arg]
- [&optional ["&optional" arg &rest arg]]
- &optional ["&rest" arg]
- )))
-
- (def-edebug-spec interactive
- (&optional &or stringp def-form))
-
- ;; A function-form is for an argument that may be a function or a form.
- ;; This specially recognizes anonymous functions quoted with quote.
- (def-edebug-spec function-form
- ;; form at the end could also handle "function",
- ;; but recognize it specially to avoid wrapping function forms.
- (&or ([&or "quote" "function"] &or symbolp lambda-expr) form))
-
- ;; function expects a symbol or a lambda or macro expression
- ;; A macro is allowed by Emacs.
- (def-edebug-spec function (&or symbolp lambda-expr))
-
- ;; lambda is a macro in emacs 19.
- (def-edebug-spec lambda (&define lambda-list
- [&optional stringp]
- [&optional ("interactive" interactive)]
- def-body))
-
- ;; A macro expression is a lambda expression with "macro" prepended.
- (def-edebug-spec macro (&define "lambda" lambda-list def-body))
-
- ;; (def-edebug-spec anonymous-form ((&or ["lambda" lambda] ["macro" macro])))
-
- ;; Standard functions that take function-forms arguments.
- (def-edebug-spec mapcar (function-form form))
- (def-edebug-spec mapconcat (function-form form form))
- (def-edebug-spec mapatoms (function-form &optional form))
- (def-edebug-spec apply (function-form &rest form))
- (def-edebug-spec funcall (function-form &rest form))
-
- (def-edebug-spec let
- ((&rest &or (symbolp &optional form) symbolp)
- body))
-
- (def-edebug-spec let* let)
-
- (def-edebug-spec setq (&rest symbolp form))
- (def-edebug-spec setq-default setq)
-
- (def-edebug-spec cond (&rest (&rest form)))
-
- (def-edebug-spec condition-case
- (symbolp
- form
- &rest (symbolp body)))
-
-
- (def-edebug-spec \` (backquote-form))
-
- ;; Supports quotes inside backquotes,
- ;; but only at the top level inside unquotes.
- (def-edebug-spec backquote-form
- (&or
- ([&or "," ",@"] &or ("quote" backquote-form) form)
- (backquote-form &rest backquote-form)
- ;; If you use dotted forms in backquotes, replace the previous line
- ;; with the following. This takes quite a bit more stack space, however.
- ;; (backquote-form . [&or nil backquote-form])
- (vector &rest backquote-form)
- sexp))
-
- ;; Special version of backquote that instruments backquoted forms
- ;; destined to be evaluated, usually as the result of a
- ;; macroexpansion. Backquoted code can only have unquotes (, and ,@)
- ;; in places where list forms are allowed, and predicates. If the
- ;; backquote is used in a macro, unquoted code that come from
- ;; arguments must be instrumented, if at all, with def-form not def-body.
-
- ;; We could assume that all forms (not nested in other forms)
- ;; in arguments of macros should be def-forms, whether or not the macros
- ;; are defined with edebug-` but this would be expensive.
-
- ;; ,@ might have some problems.
-
- (defalias 'edebug-\` '\`) ;; same macro as regular backquote.
- (def-edebug-spec edebug-\` (def-form))
-
- ;; Assume immediate quote in unquotes mean backquote at next higher level.
- (def-edebug-spec , (&or ("quote" edebug-`) def-form))
- (def-edebug-spec ,@ (&define ;; so (,@ form) is never wrapped.
- &or ("quote" edebug-`) def-form))
-
- ;; New byte compiler.
- (def-edebug-spec defsubst defun)
- (def-edebug-spec dont-compile t)
- (def-edebug-spec eval-when-compile t)
- (def-edebug-spec eval-and-compile t)
-
- ;; Anything else?
-
-
- ;; Some miscellaneous specs for macros in public packages.
- ;; Send me yours.
-
- ;; advice.el by Hans Chalupsky (hans@cs.buffalo.edu)
-
- (def-edebug-spec ad-dolist ((symbolp form &optional form) body))
- (def-edebug-spec defadvice
- (&define name ;; thing being advised.
- (name ;; class is [&or "before" "around" "after"
- ;; "activation" "deactivation"]
- name ;; name of advice
- &rest sexp ;; optional position and flags
- )
- [&optional stringp]
- [&optional ("interactive" interactive)]
- def-body))
-
- ;;; The debugger itself
-
- (defvar edebug-active nil) ;; Non-nil when edebug is active
-
- ;;; add minor-mode-alist entry
- (or (assq 'edebug-active minor-mode-alist)
- (setq minor-mode-alist (cons (list 'edebug-active " *Debugging*")
- minor-mode-alist)))
-
- (defvar edebug-stack nil)
- ;; Stack of active functions evaluated via edebug.
- ;; Should be nil at the top level.
-
- (defvar edebug-stack-depth -1)
- ;; Index of last edebug-stack item.
-
- (defvar edebug-offset-indices nil)
- ;; Stack of offset indices of visited edebug sexps.
- ;; Should be nil at the top level.
- ;; Each function adds one cons. Top is modified with setcar.
-
-
- (defvar edebug-entered nil
- ;; Non-nil if edebug has already been entered at this recursive edit level.
- ;; This should stay nil at the top level.
- )
-
- ;; Should these be options?
- (defconst edebug-debugger 'edebug
- ;; Name of function to use for debugging when error or quit occurs.
- ;; Set this to 'debug if you want to debug edebug.
- )
-
-
- ;; Dynamically bound variables, declared globally but left unbound.
- (defvar edebug-function) ; the function being executed. change name!!
- (defvar edebug-args) ; the arguments of the function
- (defvar edebug-data) ; the edebug data for the function
- (defvar edebug-value) ; the result of the expression
- (defvar edebug-after-index)
- (defvar edebug-def-mark) ; the mark for the definition
- (defvar edebug-freq-count) ; the count of expression visits.
- (defvar edebug-coverage) ; the coverage results of each expression of function.
-
- (defvar edebug-buffer) ; which buffer the function is in.
- (defvar edebug-result) ; the result of the function call returned by body
- (defvar edebug-outside-executing-macro)
- (defvar edebug-outside-defining-kbd-macro)
-
- (defvar edebug-execution-mode 'step) ; Current edebug mode set by user.
- (defvar edebug-next-execution-mode nil) ; Use once instead of initial mode.
-
- (defvar edebug-outside-debug-on-error) ; the value of debug-on-error outside
- (defvar edebug-outside-debug-on-quit) ; the value of debug-on-quit outside
-
- (defvar edebug-outside-pre-command-hook)
- (defvar edebug-outside-post-command-hook)
- (defvar edebug-outside-post-command-idle-hook)
-
- ;; Emacs 19
- (defvar pre-command-hook nil)
- (defvar post-command-hook nil)
- (defvar post-command-idle-hook nil)
-
- (defvar cl-lexical-debug) ;; Defined in cl.el
-
- ;;; Handling signals
-
- (if (not (fboundp 'edebug-original-signal))
- (defalias 'edebug-original-signal (symbol-function 'signal)))
- ;; We should use advise for this!!
-
- (defun edebug-signal (edebug-signal-name edebug-signal-data)
- "Signal an error. Args are SIGNAL-NAME, and associated DATA.
- A signal name is a symbol with an `error-conditions' property
- that is a list of condition names.
- A handler for any of those names will get to handle this signal.
- The symbol `error' should always be one of them.
-
- DATA should be a list. Its elements are printed as part of the error message.
- If the signal is handled, DATA is made available to the handler.
- See `condition-case'.
-
- This is the Edebug replacement for the standard `signal'. It should
- only be active while Edebug is. It checks `debug-on-error' to see
- whether it should call the debugger. When execution is resumed, the
- error is signaled again."
- (if (and (listp debug-on-error) (memq edebug-signal-name debug-on-error))
- (edebug 'error (cons edebug-signal-name edebug-signal-data)))
- ;; If we reach here without another non-local exit, then send signal again.
- ;; i.e. the signal is not continuable, yet.
- (edebug-original-signal edebug-signal-name edebug-signal-data))
-
-
- ;;; Entering Edebug
-
- (defun edebug-enter (edebug-function edebug-args edebug-body)
- ;; Entering FUNC. The arguments are ARGS, and the body is BODY.
- ;; Setup edebug variables and evaluate BODY. This function is called
- ;; when a function evaluated with edebug-eval-top-level-form is entered.
- ;; Return the result of BODY.
-
- ;; Is this the first time we are entering edebug since
- ;; lower-level recursive-edit command?
- ;; More precisely, this tests whether Edebug is currently active.
- (if (not edebug-entered)
- (let ((edebug-entered t)
- ;; Binding max-lisp-eval-depth here is OK,
- ;; but not inside an unwind-protect.
- ;; Doing it here also keeps it from growing too large.
- (max-lisp-eval-depth (+ 100 max-lisp-eval-depth)) ; too much??
- (max-specpdl-size (+ 200 max-specpdl-size))
-
- (debugger edebug-debugger) ; only while edebug is active.
- (edebug-outside-debug-on-error debug-on-error)
- (edebug-outside-debug-on-quit debug-on-quit)
- ;; Binding these may not be the right thing to do.
- ;; We want to allow the global values to be changed.
- (debug-on-error (or debug-on-error edebug-on-error))
- (debug-on-quit edebug-on-quit)
-
- ;; Lexical bindings must be uncompiled for this to work.
- (cl-lexical-debug t)
-
- ;; Save the outside value of executing macro. (here??)
- (edebug-outside-executing-macro executing-kbd-macro)
- (edebug-outside-pre-command-hook pre-command-hook)
- (edebug-outside-post-command-hook post-command-hook)
- (edebug-outside-post-command-idle-hook post-command-idle-hook))
- (unwind-protect
- (let (;; Don't keep reading from an executing kbd macro
- ;; within edebug unless edebug-continue-kbd-macro is
- ;; non-nil. Again, local binding may not be best.
- (executing-kbd-macro
- (if edebug-continue-kbd-macro executing-kbd-macro))
-
- ;; Disable command hooks. This is essential when
- ;; a hook function is instrumented - to avoid infinite loop.
- ;; This may be more than we need, however.
- (pre-command-hook nil)
- (post-command-hook nil)
- (post-command-idle-hook nil))
- (setq edebug-execution-mode (or edebug-next-execution-mode
- edebug-initial-mode
- edebug-execution-mode)
- edebug-next-execution-mode nil)
- ;; Bind signal to edebug-signal only while Edebug is active.
- (fset 'signal 'edebug-signal)
- (unwind-protect
- (edebug-enter edebug-function edebug-args edebug-body)
- (fset 'signal (symbol-function 'edebug-original-signal))))
- ;; Reset global variables in case outside value was changed.
- (setq executing-kbd-macro edebug-outside-executing-macro
- pre-command-hook edebug-outside-pre-command-hook
- post-command-hook edebug-outside-post-command-hook
- post-command-idle-hook edebug-outside-post-command-idle-hook
- )))
-
- (let* ((edebug-data (get edebug-function 'edebug))
- (edebug-def-mark (car edebug-data)) ; mark at def start
- (edebug-freq-count (get edebug-function 'edebug-freq-count))
- (edebug-coverage (get edebug-function 'edebug-coverage))
- (edebug-buffer (marker-buffer edebug-def-mark))
-
- (edebug-stack (cons edebug-function edebug-stack))
- (edebug-offset-indices (cons 0 edebug-offset-indices))
- )
- (if (get edebug-function 'edebug-on-entry)
- (progn
- (setq edebug-execution-mode 'step)
- (if (eq (get edebug-function 'edebug-on-entry) 'temp)
- (put edebug-function 'edebug-on-entry nil))))
- (if edebug-trace
- (edebug-enter-trace edebug-body)
- (funcall edebug-body))
- )))
-
-
- (defun edebug-enter-trace (edebug-body)
- (let ((edebug-stack-depth (1+ edebug-stack-depth))
- edebug-result)
- (edebug-print-trace-before
- (format "%s args: %s" edebug-function edebug-args))
- (prog1 (setq edebug-result (funcall edebug-body))
- (edebug-print-trace-after
- (format "%s result: %s" edebug-function edebug-result)))))
-
- (def-edebug-spec edebug-tracing (form body))
-
- (defmacro edebug-tracing (msg &rest body)
- "Print MSG in *edebug-trace* before and after evaluating BODY.
- The result of BODY is also printed."
- (` (let ((edebug-stack-depth (1+ edebug-stack-depth))
- edebug-result)
- (edebug-print-trace-before (, msg))
- (prog1 (setq edebug-result (progn (,@ body)))
- (edebug-print-trace-after
- (format "%s result: %s" (, msg) edebug-result))))))
-
- (defun edebug-print-trace-before (msg)
- "Function called to print trace info before expression evaluation.
- MSG is printed after `::::{ '."
- (edebug-trace-display
- edebug-trace-buffer "%s{ %s" (make-string edebug-stack-depth ?\:) msg))
-
- (defun edebug-print-trace-after (msg)
- "Function called to print trace info after expression evaluation.
- MSG is printed after `::::} '."
- (edebug-trace-display
- edebug-trace-buffer "%s} %s" (make-string edebug-stack-depth ?\:) msg))
-
-
-
- (defun edebug-slow-before (edebug-before-index)
- ;; Debug current function given BEFORE position.
- ;; Called from functions compiled with edebug-eval-top-level-form.
- ;; Return the before index.
- (setcar edebug-offset-indices edebug-before-index)
-
- ;; Increment frequency count
- (aset edebug-freq-count edebug-before-index
- (1+ (aref edebug-freq-count edebug-before-index)))
-
- (if (or (not (memq edebug-execution-mode '(Go-nonstop next)))
- (edebug-input-pending-p))
- (edebug-debugger edebug-before-index 'before nil))
- edebug-before-index)
-
- (defun edebug-fast-before (edebug-before-index)
- ;; Do nothing.
- )
-
- (defun edebug-slow-after (edebug-before-index edebug-after-index edebug-value)
- ;; Debug current function given AFTER position and VALUE.
- ;; Called from functions compiled with edebug-eval-top-level-form.
- ;; Return VALUE.
- (setcar edebug-offset-indices edebug-after-index)
-
- ;; Increment frequency count
- (aset edebug-freq-count edebug-after-index
- (1+ (aref edebug-freq-count edebug-after-index)))
- (if edebug-test-coverage (edebug-update-coverage))
-
- (if (and (eq edebug-execution-mode 'Go-nonstop)
- (not (edebug-input-pending-p)))
- ;; Just return result.
- edebug-value
- (edebug-debugger edebug-after-index 'after edebug-value)
- ))
-
- (defun edebug-fast-after (edebug-before-index edebug-after-index edebug-value)
- ;; Do nothing but return the value.
- edebug-value)
-
- (defun edebug-run-slow ()
- (defalias 'edebug-before 'edebug-slow-before)
- (defalias 'edebug-after 'edebug-slow-after))
-
- ;; This is not used, yet.
- (defun edebug-run-fast ()
- (defalias 'edebug-before 'edebug-fast-before)
- (defalias 'edebug-after 'edebug-fast-after))
-
- (edebug-run-slow)
-
-
- (defun edebug-update-coverage ()
- (let ((old-result (aref edebug-coverage edebug-after-index)))
- (cond
- ((eq 'ok-coverage old-result))
- ((eq 'unknown old-result)
- (aset edebug-coverage edebug-after-index edebug-value))
- ;; Test if a different result.
- ((not (eq edebug-value old-result))
- (aset edebug-coverage edebug-after-index 'ok-coverage)))))
-
-
- ;; Dynamically declared unbound variables.
- (defvar edebug-arg-mode) ; the mode, either before, after, or error
- (defvar edebug-breakpoints)
- (defvar edebug-break-data) ; break data for current function.
- (defvar edebug-break) ; whether a break occurred.
- (defvar edebug-global-break) ; whether a global break occurred.
- (defvar edebug-break-condition) ; whether the breakpoint is conditional.
-
- (defvar edebug-break-result nil)
- (defvar edebug-global-break-result nil)
-
-
- (defun edebug-debugger (edebug-offset-index edebug-arg-mode edebug-value)
- ;; Check breakpoints and pending input.
- ;; If edebug display should be updated, call edebug-display.
- ;; Return edebug-value.
- (let* (;; This needs to be here since breakpoints may be changed.
- (edebug-breakpoints (car (cdr edebug-data))) ; list of breakpoints
- (edebug-break-data (assq edebug-offset-index edebug-breakpoints))
- (edebug-break-condition (car (cdr edebug-break-data)))
- (edebug-global-break
- (if edebug-global-break-condition
- (condition-case nil
- (setq edebug-global-break-result
- (eval edebug-global-break-condition))
- (error nil))))
- (edebug-break))
-
- ;;; (edebug-trace "exp: %s" edebug-value)
- ;; Test whether we should break.
- (setq edebug-break
- (or edebug-global-break
- (and edebug-break-data
- (or (not edebug-break-condition)
- (setq edebug-break-result
- (eval edebug-break-condition))))))
- (if (and edebug-break
- (nth 2 edebug-break-data)) ; is it temporary?
- ;; Delete the breakpoint.
- (setcdr edebug-data
- (cons (delq edebug-break-data edebug-breakpoints)
- (cdr (cdr edebug-data)))))
-
- ;; Display if mode is not go, continue, or Continue-fast
- ;; or break, or input is pending,
- (if (or (not (memq edebug-execution-mode '(go continue Continue-fast)))
- edebug-break
- (edebug-input-pending-p))
- (edebug-display)) ; <--------------- display
-
- edebug-value
- ))
-
-
- ;; window-start now stored with each function.
- ;;(defvar edebug-window-start nil)
- ;; Remember where each buffers' window starts between edebug calls.
- ;; This is to avoid spurious recentering.
- ;; Does this still need to be buffer-local??
- ;;(setq-default edebug-window-start nil)
- ;;(make-variable-buffer-local 'edebug-window-start)
-
-
- ;; Dynamically declared unbound vars
- (defvar edebug-point) ; the point in edebug buffer
- (defvar edebug-outside-buffer) ; the current-buffer outside of edebug
- (defvar edebug-outside-point) ; the point outside of edebug
- (defvar edebug-outside-mark) ; the mark outside of edebug
- (defvar edebug-window-data) ; window and window-start for current function
- (defvar edebug-outside-windows) ; outside window configuration
- (defvar edebug-eval-buffer) ; for the evaluation list.
- (defvar edebug-outside-o-a-p) ; outside overlay-arrow-position
- (defvar edebug-outside-o-a-s) ; outside overlay-arrow-string
- (defvar edebug-outside-c-i-e-a) ; outside cursor-in-echo-area
-
- (defvar edebug-eval-list nil) ;; List of expressions to evaluate.
-
- (defvar edebug-previous-result nil) ;; Last result returned.
-
- ;; Emacs 19 adds an arg to mark and mark-marker.
- (defalias 'edebug-mark 'mark)
- (defalias 'edebug-mark-marker 'mark-marker)
-
-
- (defun edebug-display ()
- ;; Setup windows for edebug, determine mode, maybe enter recursive-edit.
- ;; Uses local variables of edebug-enter, edebug-before, edebug-after
- ;; and edebug-debugger.
- (let ((edebug-active t) ; for minor mode alist
- edebug-stop ; should we enter recursive-edit
- (edebug-point (+ edebug-def-mark
- (aref (nth 2 edebug-data) edebug-offset-index)))
- edebug-buffer-outside-point ; current point in edebug-buffer
- ;; window displaying edebug-buffer
- (edebug-window-data (nth 3 edebug-data))
- (edebug-outside-window (selected-window))
- (edebug-outside-buffer (current-buffer))
- (edebug-outside-point (point))
- (edebug-outside-mark (edebug-mark))
- edebug-outside-windows ; window or screen configuration
- edebug-buffer-points
-
- edebug-eval-buffer ; declared here so we can kill it below
- (edebug-eval-result-list (and edebug-eval-list
- (edebug-eval-result-list)))
- edebug-trace-window
- edebug-trace-window-start
-
- (edebug-outside-o-a-p overlay-arrow-position)
- (edebug-outside-o-a-s overlay-arrow-string)
- (edebug-outside-c-i-e-a cursor-in-echo-area))
- (unwind-protect
- (let ((overlay-arrow-position overlay-arrow-position)
- (overlay-arrow-string overlay-arrow-string)
- (cursor-in-echo-area nil)
- ;; any others??
- )
- (if (not (buffer-name edebug-buffer))
- (let ((debug-on-error nil))
- (error "Buffer defining %s not found" edebug-function)))
-
- (if (eq 'after edebug-arg-mode)
- ;; Compute result string now before windows are modified.
- (edebug-compute-previous-result edebug-value))
-
- (if edebug-save-windows
- ;; Save windows now before we modify them.
- (setq edebug-outside-windows
- (edebug-current-windows edebug-save-windows)))
-
- (if edebug-save-displayed-buffer-points
- (setq edebug-buffer-points (edebug-get-displayed-buffer-points)))
-
- ;; First move the edebug buffer point to edebug-point
- ;; so that window start doesn't get changed when we display it.
- ;; I don't know if this is going to help.
- ;;(set-buffer edebug-buffer)
- ;;(goto-char edebug-point)
-
- ;; If edebug-buffer is not currently displayed,
- ;; first find a window for it.
- (edebug-pop-to-buffer edebug-buffer (car edebug-window-data))
- (setcar edebug-window-data (selected-window))
-
- ;; Now display eval list, if any.
- ;; This is done after the pop to edebug-buffer
- ;; so that buffer-window correspondence is correct after quitting.
- (edebug-eval-display edebug-eval-result-list)
- ;; The evaluation list better not have deleted edebug-window-data.
- (select-window (car edebug-window-data))
- (set-buffer edebug-buffer)
-
- (setq edebug-buffer-outside-point (point))
- (goto-char edebug-point)
-
- (if (eq 'before edebug-arg-mode)
- ;; Check whether positions are up-to-date.
- ;; This assumes point is never before symbol.
- (if (not (memq (following-char) '(?\( ?\# ?\` )))
- (let ((debug-on-error nil))
- (error "Source has changed - reevaluate definition of %s"
- edebug-function)
- )))
-
- (setcdr edebug-window-data
- (edebug-adjust-window (cdr edebug-window-data)))
-
- ;; Test if there is input, not including keyboard macros.
- (if (edebug-input-pending-p)
- (progn
- (setq edebug-execution-mode 'step
- edebug-stop t)
- (edebug-stop)
- ;; (discard-input) ; is this unfriendly??
- ))
- ;; Now display arrow based on mode.
- (edebug-overlay-arrow)
-
- (cond
- ((eq 'error edebug-arg-mode)
- ;; Display error message
- (setq edebug-execution-mode 'step)
- (edebug-overlay-arrow)
- (beep)
- (if (eq 'quit (car edebug-value))
- (message "Quit")
- (edebug-report-error edebug-value)))
- (edebug-break
- (cond
- (edebug-global-break
- (message "Global Break: %s => %s"
- edebug-global-break-condition
- edebug-global-break-result))
- (edebug-break-condition
- (message "Break: %s => %s"
- edebug-break-condition
- edebug-break-result))
- ((not (eq edebug-execution-mode 'Continue-fast))
- (message "Break"))
- (t)))
-
- (t (message "")))
-
- (if (eq 'after edebug-arg-mode)
- (progn
- ;; Display result of previous evaluation.
- (if (and edebug-break
- (not (eq edebug-execution-mode 'Continue-fast)))
- (sit-for 1)) ; Show break message.
- (edebug-previous-result)))
-
- (cond
- (edebug-break
- (cond
- ((eq edebug-execution-mode 'continue) (edebug-sit-for 1))
- ((eq edebug-execution-mode 'Continue-fast) (edebug-sit-for 0))
- (t (setq edebug-stop t))))
- ;; not edebug-break
- ((eq edebug-execution-mode 'trace)
- (edebug-sit-for 1)) ; Force update and pause.
- ((eq edebug-execution-mode 'Trace-fast)
- (edebug-sit-for 0)) ; Force update and continue.
- )
-
- (unwind-protect
- (if (or edebug-stop
- (memq edebug-execution-mode '(step next))
- (eq edebug-arg-mode 'error))
- (progn
- ;; (setq edebug-execution-mode 'step)
- ;; (edebug-overlay-arrow) ; This doesn't always show up.
- (edebug-recursive-edit))) ; <---------- Recursive edit
-
- ;; Reset the edebug-window-data to whatever it is now.
- (let ((window (if (eq (window-buffer) edebug-buffer)
- (selected-window)
- (edebug-get-buffer-window edebug-buffer))))
- ;; Remember window-start for edebug-buffer, if still displayed.
- (if window
- (progn
- (setcar edebug-window-data window)
- (setcdr edebug-window-data (window-start window)))))
-
- ;; Save trace window point before restoring outside windows.
- ;; Could generalize this for other buffers.
- (setq edebug-trace-window (get-buffer-window edebug-trace-buffer))
- (if edebug-trace-window
- (setq edebug-trace-window-start
- (and edebug-trace-window
- (window-start edebug-trace-window))))
-
- ;; Restore windows before continuing.
- (if edebug-save-windows
- (progn
- (edebug-set-windows edebug-outside-windows)
-
- ;; Restore displayed buffer points.
- ;; Needed even if restoring windows because
- ;; window-points are not restored. (should they be??)
- (if edebug-save-displayed-buffer-points
- (edebug-set-buffer-points edebug-buffer-points))
-
- ;; Unrestore trace window's window-point.
- (if edebug-trace-window
- (set-window-start edebug-trace-window
- edebug-trace-window-start))
-
- ;; Unrestore edebug-buffer's window-start, if displayed.
- (let ((window (car edebug-window-data)))
- (if (and window (edebug-window-live-p window)
- (eq (window-buffer) edebug-buffer))
- (progn
- (set-window-start window (cdr edebug-window-data)
- 'no-force)
- ;; Unrestore edebug-buffer's window-point.
- ;; Needed in addition to setting the buffer point
- ;; - otherwise quitting doesn't leave point as is.
- ;; But this causes point to not be restored at times.
- ;; Also, it may not be a visible window.
- ;; (set-window-point window edebug-point)
- )))
-
- ;; Unrestore edebug-buffer's point. Rerestored below.
- ;; (goto-char edebug-point) ;; in edebug-buffer
- )
- ;; Since we may be in a save-excursion, in case of quit,
- ;; reselect the outside window only.
- ;; Only needed if we are not recovering windows??
- (if (edebug-window-live-p edebug-outside-window)
- (select-window edebug-outside-window))
- ) ; if edebug-save-windows
-
- ;; Restore current buffer always, in case application needs it.
- (set-buffer edebug-outside-buffer)
- ;; Restore point, and mark.
- ;; Needed even if restoring windows because
- ;; that doesn't restore point and mark in the current buffer.
- ;; But don't restore point if edebug-buffer is current buffer.
- (if (not (eq edebug-buffer edebug-outside-buffer))
- (goto-char edebug-outside-point))
- (if (marker-buffer (edebug-mark-marker))
- ;; Does zmacs-regions need to be nil while doing set-marker?
- (set-marker (edebug-mark-marker) edebug-outside-mark))
- ) ; unwind-protect
- ;; None of the following is done if quit or signal occurs.
-
- ;; Restore edebug-buffer's outside point.
- ;; (edebug-trace "restore edebug-buffer point: %s"
- ;; edebug-buffer-outside-point)
- (let ((current-buffer (current-buffer)))
- (set-buffer edebug-buffer)
- (goto-char edebug-buffer-outside-point)
- (set-buffer current-buffer))
- ;; ... nothing more.
- )
- ;; Reset global variables to outside values in case they were changed.
- (setq
- overlay-arrow-position edebug-outside-o-a-p
- overlay-arrow-string edebug-outside-o-a-s
- cursor-in-echo-area edebug-outside-c-i-e-a)
- )))
-
-
- (defvar edebug-number-of-recursions 0)
- ;; Number of recursive edits started by edebug.
- ;; Should be 0 at the top level.
-
- (defvar edebug-recursion-depth 0)
- ;; Value of recursion-depth when edebug was called.
-
- ;; Dynamically declared unbound vars
- (defvar edebug-outside-match-data) ; match data outside of edebug
- (defvar edebug-backtrace-buffer) ; each recursive edit gets its own
- (defvar edebug-inside-windows)
- (defvar edebug-interactive-p)
-
- (defvar edebug-outside-map)
- (defvar edebug-outside-standard-output)
- (defvar edebug-outside-standard-input)
- (defvar edebug-outside-last-command-char)
- (defvar edebug-outside-last-command)
- (defvar edebug-outside-this-command)
- (defvar edebug-outside-last-input-char)
-
- ;; Note: here we have defvars for variables that are
- ;; built-in in certain versions.
- ;; Each defvar makes a difference
- ;; in versions where the variable is *not* built-in.
-
- ;; Emacs 18
- (defvar edebug-outside-unread-command-char)
-
- ;; Lucid Emacs
- (defvar edebug-outside-unread-command-event) ;; like unread-command-events
- (defvar unread-command-event nil)
-
- ;; Emacs 19.
- (defvar edebug-outside-last-command-event)
- (defvar edebug-outside-unread-command-events)
- (defvar edebug-outside-last-input-event)
- (defvar edebug-outside-last-event-frame)
- (defvar edebug-outside-last-nonmenu-event)
- (defvar edebug-outside-track-mouse)
-
- ;; Disable byte compiler warnings about unread-command-char and -event
- ;; (maybe works with byte-compile-version 2.22 at least)
- (defvar edebug-unread-command-char-warning)
- (defvar edebug-unread-command-event-warning)
- (eval-when-compile
- (setq edebug-unread-command-char-warning
- (get 'unread-command-char 'byte-obsolete-variable))
- (put 'unread-command-char 'byte-obsolete-variable nil)
- (setq edebug-unread-command-event-warning
- (get 'unread-command-event 'byte-obsolete-variable))
- (put 'unread-command-event 'byte-obsolete-variable nil))
-
- (defun edebug-recursive-edit ()
- ;; Start up a recursive edit inside of edebug.
- ;; The current buffer is the edebug-buffer, which is put into edebug-mode.
- ;; Assume that none of the variables below are buffer-local.
- (let ((edebug-buffer-read-only buffer-read-only)
- ;; match-data must be done in the outside buffer
- (edebug-outside-match-data
- (save-excursion ; might be unnecessary now??
- (set-buffer edebug-outside-buffer) ; in case match buffer different
- (match-data)))
-
- ;;(edebug-number-of-recursions (1+ edebug-number-of-recursions))
- (edebug-recursion-depth (recursion-depth))
- edebug-entered ; bind locally to nil
- (edebug-interactive-p nil) ; again non-interactive
- edebug-backtrace-buffer ; each recursive edit gets its own
- ;; The window configuration may be saved and restored
- ;; during a recursive-edit
- edebug-inside-windows
-
- (edebug-outside-map (current-local-map))
-
- (edebug-outside-standard-output standard-output)
- (edebug-outside-standard-input standard-input)
- (edebug-outside-defining-kbd-macro defining-kbd-macro)
-
- (edebug-outside-last-command-char last-command-char)
- (edebug-outside-last-command last-command)
- (edebug-outside-this-command this-command)
- (edebug-outside-last-input-char last-input-char)
-
- (edebug-outside-unread-command-char unread-command-char)
-
- (edebug-outside-last-input-event last-input-event)
- (edebug-outside-last-command-event last-command-event)
- (edebug-outside-unread-command-event unread-command-event)
- (edebug-outside-unread-command-events unread-command-events)
- (edebug-outside-last-event-frame last-event-frame)
- (edebug-outside-last-nonmenu-event last-nonmenu-event)
- (edebug-outside-track-mouse track-mouse)
- )
-
- (unwind-protect
- (let (
- ;; Declare global values local but using the same global value.
- ;; We could set these to the values for previous edebug call.
- (last-command-char last-command-char)
- (last-command last-command)
- (this-command this-command)
- (last-input-char last-input-char)
-
- ;; Assume no edebug command sets unread-command-char.
- (unread-command-char -1)
-
- ;; More for Emacs 19
- (last-input-event nil)
- (last-command-event nil)
- (unread-command-event nil);; lemacs
- (unread-command-events nil)
- (last-event-frame nil)
- (last-nonmenu-event nil)
- (track-mouse nil)
-
- ;; Bind again to outside values.
- (debug-on-error edebug-outside-debug-on-error)
- (debug-on-quit edebug-outside-debug-on-quit)
-
- ;; Don't keep defining a kbd macro.
- (defining-kbd-macro
- (if edebug-continue-kbd-macro defining-kbd-macro))
-
- ;; others??
- )
-
- (if (fboundp 'zmacs-deactivate-region);; for lemacs
- (zmacs-deactivate-region))
- (if (and (eq edebug-execution-mode 'go)
- (not (memq edebug-arg-mode '(after error))))
- (message "Break"))
-
- (setq buffer-read-only t)
- (fset 'signal (symbol-function 'edebug-original-signal))
-
- (edebug-mode)
- (unwind-protect
- (recursive-edit) ; <<<<<<<<<< Recursive edit
-
- ;; Do the following, even if quit occurs.
- (fset 'signal 'edebug-signal)
- (if edebug-backtrace-buffer
- (kill-buffer edebug-backtrace-buffer))
- ;; Could be an option to keep eval display up.
- (if edebug-eval-buffer (kill-buffer edebug-eval-buffer))
-
- ;; Remember selected-window after recursive-edit.
- ;; (setq edebug-inside-window (selected-window))
-
- (store-match-data edebug-outside-match-data)
-
- ;; Recursive edit may have changed buffers,
- ;; so set it back before exiting let.
- (if (buffer-name edebug-buffer) ; if it still exists
- (progn
- (set-buffer edebug-buffer)
- (if (memq edebug-execution-mode '(go Go-nonstop))
- (edebug-overlay-arrow))
- (setq buffer-read-only edebug-buffer-read-only)
- (use-local-map edebug-outside-map)
- )
- ;; gotta have a buffer to let its buffer local variables be set
- (get-buffer-create " bogus edebug buffer"))
- ));; inner let
-
- ;; Reset global vars to outside values, in case they have been changed.
- (setq
- last-command-char edebug-outside-last-command-char
- last-command-event edebug-outside-last-command-event
- last-command edebug-outside-last-command
- this-command edebug-outside-this-command
- unread-command-char edebug-outside-unread-command-char
- unread-command-event edebug-outside-unread-command-event
- unread-command-events edebug-outside-unread-command-events
- last-input-char edebug-outside-last-input-char
- last-input-event edebug-outside-last-input-event
- last-event-frame edebug-outside-last-event-frame
- last-nonmenu-event edebug-outside-last-nonmenu-event
- track-mouse edebug-outside-track-mouse
-
- standard-output edebug-outside-standard-output
- standard-input edebug-outside-standard-input
- defining-kbd-macro edebug-outside-defining-kbd-macro
- ))
- ))
-
-
- ;;; Display related functions
-
- (defun edebug-adjust-window (old-start)
- ;; If pos is not visible, adjust current window to fit following context.
- ;;; (message "window: %s old-start: %s window-start: %s pos: %s"
- ;;; (selected-window) old-start (window-start) (point)) (sit-for 5)
- (if (not (pos-visible-in-window-p))
- (progn
- ;; First try old-start
- (if old-start
- (set-window-start (selected-window) old-start))
- (if (not (pos-visible-in-window-p))
- (progn
- ;; (message "resetting window start") (sit-for 2)
- (set-window-start
- (selected-window)
- (save-excursion
- (forward-line
- (if (< (point) (window-start)) -1 ; one line before if in back
- (- (/ (window-height) 2)) ; center the line moving forward
- ))
- (beginning-of-line)
- (point)))))))
- (window-start))
-
-
-
- (defconst edebug-arrow-alist
- '((Continue-fast . "=")
- (Trace-fast . "-")
- (continue . ">")
- (trace . "->")
- (step . "=>")
- (next . "=>")
- (go . "<>")
- (Go-nonstop . "..") ; not used
- )
- "Association list of arrows for each edebug mode.")
-
- (defun edebug-overlay-arrow ()
- ;; Set up the overlay arrow at beginning-of-line in current buffer.
- ;; The arrow string is derived from edebug-arrow-alist and
- ;; edebug-execution-mode.
- (let ((pos (save-excursion (beginning-of-line) (point))))
- (setq overlay-arrow-string
- (cdr (assq edebug-execution-mode edebug-arrow-alist)))
- (setq overlay-arrow-position (make-marker))
- (set-marker overlay-arrow-position pos (current-buffer))))
-
-
- (defun edebug-toggle-save-all-windows ()
- "Toggle the saving and restoring of all windows.
- Also, each time you toggle it on, the inside and outside window
- configurations become the same as the current configuration."
- (interactive)
- (setq edebug-save-windows (not edebug-save-windows))
- (if edebug-save-windows
- (setq edebug-inside-windows
- (setq edebug-outside-windows
- (edebug-current-windows
- edebug-save-windows))))
- (message "Window saving is %s for all windows."
- (if edebug-save-windows "on" "off")))
-
- (defmacro edebug-changing-windows (&rest body)
- (` (let ((window (selected-window)))
- (setq edebug-inside-windows (edebug-current-windows t))
- (edebug-set-windows edebug-outside-windows)
- (,@ body) ;; Code to change edebug-save-windows
- (setq edebug-outside-windows (edebug-current-windows
- edebug-save-windows))
- ;; Problem: what about outside windows that are deleted inside?
- (edebug-set-windows edebug-inside-windows))))
-
- (defun edebug-toggle-save-selected-window ()
- "Toggle the saving and restoring of the selected window.
- Also, each time you toggle it on, the inside and outside window
- configurations become the same as the current configuration."
- (interactive)
- (cond
- ((eq t edebug-save-windows)
- ;; Save all outside windows except the selected one.
- ;; Remove (selected-window) from outside-windows.
- (edebug-changing-windows
- (setq edebug-save-windows (delq window (edebug-window-list)))))
-
- ((memq (selected-window) edebug-save-windows)
- (setq edebug-outside-windows
- (delq (assq (selected-window) edebug-outside-windows)
- edebug-outside-windows))
- (setq edebug-save-windows
- (delq (selected-window) edebug-save-windows)))
- (t ; Save a new window.
- (edebug-changing-windows
- (setq edebug-save-windows (cons window edebug-save-windows)))))
-
- (message "Window saving is %s for %s."
- (if (memq (selected-window) edebug-save-windows)
- "on" "off")
- (selected-window)))
-
- (defun edebug-toggle-save-windows (arg)
- "Toggle the saving and restoring of windows.
- With prefix, toggle for just the selected window.
- Otherwise, toggle for all windows."
- (interactive "P")
- (if arg
- (edebug-toggle-save-selected-window)
- (edebug-toggle-save-all-windows)))
-
-
- (defun edebug-where ()
- "Show the debug windows and where we stopped in the program."
- (interactive)
- (if (not edebug-active)
- (error "Edebug is not active"))
- ;; Restore the window configuration to what it last was inside.
- ;; But it is not always set. - experiment
- ;;(if edebug-inside-windows
- ;; (edebug-set-windows edebug-inside-windows))
- (edebug-pop-to-buffer edebug-buffer)
- (goto-char edebug-point))
-
- (defun edebug-view-outside ()
- "Change to the outside window configuration."
- (interactive)
- (if (not edebug-active)
- (error "Edebug is not active"))
- (setq edebug-inside-windows
- (edebug-current-windows edebug-save-windows))
- (edebug-set-windows edebug-outside-windows)
- (goto-char edebug-outside-point)
- (message "Window configuration outside of Edebug. Return with %s"
- (substitute-command-keys "\\<global-map>\\[edebug-where]")))
-
-
- (defun edebug-bounce-point (arg)
- "Bounce the point in the outside current buffer.
- If prefix arg is supplied, sit for that many seconds before returning.
- The default is one second."
- (interactive "p")
- (if (not edebug-active)
- (error "Edebug is not active"))
- (save-excursion
- ;; If the buffer's currently displayed, avoid set-window-configuration.
- (save-window-excursion
- (edebug-pop-to-buffer edebug-outside-buffer)
- (goto-char edebug-outside-point)
- (message "Current buffer: %s Point: %s Mark: %s"
- (current-buffer) (point)
- (if (marker-buffer (edebug-mark-marker))
- (marker-position (edebug-mark-marker)) "<not set>"))
- (edebug-sit-for arg)
- (edebug-pop-to-buffer edebug-buffer (car edebug-window-data)))))
-
-
- ;; Joe Wells, here is a start at your idea of adding a buffer to the internal
- ;; display list. Still need to use this list in edebug-display.
-
- '(defvar edebug-display-buffer-list nil
- "List of buffers that edebug will display when it is active.")
-
- '(defun edebug-display-buffer (buffer)
- "Toggle display of a buffer inside of edebug."
- (interactive "bBuffer: ")
- (let ((already-displaying (memq buffer edebug-display-buffer-list)))
- (setq edebug-display-buffer-list
- (if already-displaying
- (delq buffer edebug-display-buffer-list)
- (cons buffer edebug-display-buffer-list)))
- (message "Displaying %s %s" buffer
- (if already-displaying "off" "on"))))
-
- ;;; Breakpoint related functions
-
- (defun edebug-find-stop-point ()
- ;; Return (function . index) of the nearest edebug stop point.
- (let* ((edebug-def-name (edebug-form-data-symbol))
- (edebug-data
- (let ((data (get edebug-def-name 'edebug)))
- (if (or (null data) (markerp data))
- (error "%s is not instrumented for Edebug" edebug-def-name))
- data)) ; we could do it automatically, if data is a marker.
- ;; pull out parts of edebug-data.
- (edebug-def-mark (car edebug-data))
- ;; (edebug-breakpoints (car (cdr edebug-data)))
-
- (offset-vector (nth 2 edebug-data))
- (offset (- (save-excursion
- (if (looking-at "[ \t]")
- ;; skip backwards until non-whitespace, or bol
- (skip-chars-backward " \t"))
- (point))
- edebug-def-mark))
- len i)
- ;; the offsets are in order so we can do a linear search
- (setq len (length offset-vector))
- (setq i 0)
- (while (and (< i len) (> offset (aref offset-vector i)))
- (setq i (1+ i)))
- (if (and (< i len)
- (<= offset (aref offset-vector i)))
- ;; return the relevant info
- (cons edebug-def-name i)
- (message "Point is not on an expression in %s."
- edebug-def-name)
- )))
-
-
- (defun edebug-next-breakpoint ()
- "Move point to the next breakpoint, or first if none past point."
- (interactive)
- (let ((edebug-stop-point (edebug-find-stop-point)))
- (if edebug-stop-point
- (let* ((edebug-def-name (car edebug-stop-point))
- (index (cdr edebug-stop-point))
- (edebug-data (get edebug-def-name 'edebug))
-
- ;; pull out parts of edebug-data
- (edebug-def-mark (car edebug-data))
- (edebug-breakpoints (car (cdr edebug-data)))
- (offset-vector (nth 2 edebug-data))
- breakpoint)
- (if (not edebug-breakpoints)
- (message "No breakpoints in this function.")
- (let ((breaks edebug-breakpoints))
- (while (and breaks
- (<= (car (car breaks)) index))
- (setq breaks (cdr breaks)))
- (setq breakpoint
- (if breaks
- (car breaks)
- ;; goto the first breakpoint
- (car edebug-breakpoints)))
- (goto-char (+ edebug-def-mark
- (aref offset-vector (car breakpoint))))
-
- (message "%s"
- (concat (if (nth 2 breakpoint)
- "Temporary " "")
- (if (car (cdr breakpoint))
- (format "Condition: %s"
- (edebug-safe-prin1-to-string
- (car (cdr breakpoint))))
- "")))
- ))))))
-
-
- (defun edebug-modify-breakpoint (flag &optional condition temporary)
- "Modify the breakpoint for the form at point or after it according
- to FLAG: set if t, clear if nil. Then move to that point.
- If CONDITION or TEMPORARY are non-nil, add those attributes to
- the breakpoint. "
- (let ((edebug-stop-point (edebug-find-stop-point)))
- (if edebug-stop-point
- (let* ((edebug-def-name (car edebug-stop-point))
- (index (cdr edebug-stop-point))
- (edebug-data (get edebug-def-name 'edebug))
-
- ;; pull out parts of edebug-data
- (edebug-def-mark (car edebug-data))
- (edebug-breakpoints (car (cdr edebug-data)))
- (offset-vector (nth 2 edebug-data))
- present)
- ;; delete it either way
- (setq present (assq index edebug-breakpoints))
- (setq edebug-breakpoints (delq present edebug-breakpoints))
- (if flag
- (progn
- ;; add it to the list and resort
- (setq edebug-breakpoints
- (edebug-sort-alist
- (cons
- (list index condition temporary)
- edebug-breakpoints) '<))
- (if condition
- (message "Breakpoint set in %s with condition: %s"
- edebug-def-name condition)
- (message "Breakpoint set in %s" edebug-def-name)))
- (if present
- (message "Breakpoint unset in %s" edebug-def-name)
- (message "No breakpoint here")))
-
- (setcar (cdr edebug-data) edebug-breakpoints)
- (goto-char (+ edebug-def-mark (aref offset-vector index)))
- ))))
-
- (defun edebug-set-breakpoint (arg)
- "Set the breakpoint of nearest sexp.
- With prefix argument, make it a temporary breakpoint."
- (interactive "P")
- (edebug-modify-breakpoint t nil arg))
-
- (defun edebug-unset-breakpoint ()
- "Clear the breakpoint of nearest sexp."
- (interactive)
- (edebug-modify-breakpoint nil))
-
-
- ;; For emacs 18, no read-expression-history
- (defun edebug-set-conditional-breakpoint (arg condition)
- "Set a conditional breakpoint at nearest sexp.
- The condition is evaluated in the outside context.
- With prefix argument, make it a temporary breakpoint."
- ;; (interactive "P\nxCondition: ")
- (interactive
- (list
- current-prefix-arg
- ;; Edit previous condition as follows, but it is cumbersome:
- (let ((edebug-stop-point (edebug-find-stop-point)))
- (if edebug-stop-point
- (let* ((edebug-def-name (car edebug-stop-point))
- (index (cdr edebug-stop-point))
- (edebug-data (get edebug-def-name 'edebug))
- (edebug-breakpoints (car (cdr edebug-data)))
- (edebug-break-data (assq index edebug-breakpoints))
- (edebug-break-condition (car (cdr edebug-break-data))))
- (read-minibuffer
- (format "Condition in %s: " edebug-def-name)
- (if edebug-break-condition
- (format "%s" edebug-break-condition)
- (format ""))))))))
- (edebug-modify-breakpoint t condition arg))
-
-
- (defun edebug-set-global-break-condition (expression)
- (interactive (list (read-minibuffer
- "Global Condition: "
- (format "%s" edebug-global-break-condition))))
- (setq edebug-global-break-condition expression))
-
-
- ;;; Mode switching functions
-
- (defun edebug-set-mode (mode shortmsg msg)
- ;; Set the edebug mode to MODE.
- ;; Display SHORTMSG, or MSG if not within edebug.
- (if (eq (1+ edebug-recursion-depth) (recursion-depth))
- (progn
- (setq edebug-execution-mode mode)
- (message shortmsg)
- ;; Continue execution
- (exit-recursive-edit))
- ;; This is not terribly useful!!
- (setq edebug-next-execution-mode mode)
- (message msg)))
-
-
- (defalias 'edebug-step-through-mode 'edebug-step-mode)
-
- (defun edebug-step-mode ()
- "Proceed to next stop point."
- (interactive)
- (edebug-set-mode 'step "" "Edebug will stop at next stop point."))
-
- (defun edebug-next-mode ()
- "Proceed to next `after' stop point."
- (interactive)
- (edebug-set-mode 'next "" "Edebug will stop after next eval."))
-
- (defun edebug-go-mode (arg)
- "Go, evaluating until break.
- With prefix ARG, set temporary break at current point and go."
- (interactive "P")
- (if arg
- (edebug-set-breakpoint t))
- (edebug-set-mode 'go "Go..." "Edebug will go until break."))
-
- (defun edebug-Go-nonstop-mode ()
- "Go, evaluating without debugging."
- (interactive)
- (edebug-set-mode 'Go-nonstop "Go-Nonstop..."
- "Edebug will not stop at breaks."))
-
-
- (defun edebug-trace-mode ()
- "Begin trace mode."
- (interactive)
- (edebug-set-mode 'trace "Tracing..." "Edebug will trace with pause."))
-
- (defun edebug-Trace-fast-mode ()
- "Trace with no wait at each step."
- (interactive)
- (edebug-set-mode 'Trace-fast
- "Trace fast..." "Edebug will trace without pause."))
-
- (defun edebug-continue-mode ()
- "Begin continue mode."
- (interactive)
- (edebug-set-mode 'continue "Continue..."
- "Edebug will pause at breakpoints."))
-
- (defun edebug-Continue-fast-mode ()
- "Trace with no wait at each step."
- (interactive)
- (edebug-set-mode 'Continue-fast "Continue fast..."
- "Edebug will stop and go at breakpoints."))
-
- ;; ------------------------------------------------------------
- ;; The following use the mode changing commands and breakpoints.
-
-
- (defun edebug-goto-here ()
- "Proceed to this stop point."
- (interactive)
- (edebug-go-mode t))
-
-
- (defun edebug-stop ()
- "Stop execution and do not continue.
- Useful for exiting from trace or continue loop."
- (interactive)
- (message "Stop"))
-
-
- '(defun edebug-forward ()
- "Proceed to the exit of the next expression to be evaluated."
- (interactive)
- (edebug-set-mode
- 'forward "Forward"
- "Edebug will stop after exiting the next expression."))
-
-
- (defun edebug-forward-sexp (arg)
- "Proceed from the current point to the end of the ARGth sexp ahead.
- If there are not ARG sexps ahead, then do edebug-step-out."
- (interactive "p")
- (condition-case nil
- (let ((parse-sexp-ignore-comments t))
- ;; Call forward-sexp repeatedly until done or failure.
- (forward-sexp arg)
- (edebug-go-mode t))
- (error
- (edebug-step-out)
- )))
-
- (defun edebug-step-out ()
- "Proceed from the current point to the end of the containing sexp.
- If there is no containing sexp that is not the top level defun,
- go to the end of the last sexp, or if that is the same point, then step."
- (interactive)
- (condition-case nil
- (let ((parse-sexp-ignore-comments t))
- (up-list 1)
- (save-excursion
- ;; Is there still a containing expression?
- (up-list 1))
- (edebug-go-mode t))
- (error
- ;; At top level - 1, so first check if there are more sexps at this level.
- (let ((start-point (point)))
- ;; (up-list 1)
- (down-list -1)
- (if (= (point) start-point)
- (edebug-step-mode) ; No more at this level, so step.
- (edebug-go-mode t)
- )))))
-
- (defun edebug-instrument-function (func)
- ;; Func should be a function symbol.
- ;; Return the function symbol, or nil if not instrumented.
- (let ((func-marker))
- (setq func-marker (get func 'edebug))
- (cond
- ((markerp func-marker)
- ;; It is uninstrumented, so instrument it.
- (save-excursion
- (set-buffer (marker-buffer func-marker))
- (goto-char func-marker)
- (edebug-eval-top-level-form)
- func))
- ((consp func-marker)
- (message "%s is already instrumented." func)
- func)
- (t
- ;; We could try harder, e.g. do a tags search.
- (error "Don't know where %s is defined" func)
- nil))))
-
- (defun edebug-instrument-callee ()
- "Instrument the definition of the function or macro about to be called.
- Do this when stopped before the form or it will be too late.
- One side effect of using this command is that the next time the
- function or macro is called, Edebug will be called there as well."
- (interactive)
- (if (not (looking-at "\("))
- (error "You must be before a list form")
- (let ((func
- (save-excursion
- (down-list 1)
- (if (looking-at "\(")
- (edebug-form-data-name
- (edebug-get-form-data-entry (point)))
- (edebug-original-read (current-buffer))))))
- (edebug-instrument-function func))))
-
-
- (defun edebug-step-in ()
- "Step into the definition of the function or macro about to be called.
- This first does `edebug-instrument-callee' to ensure that it is
- instrumented. Then it does `edebug-on-entry' and switches to `go' mode."
- (interactive)
- (let ((func (edebug-instrument-callee)))
- (if func
- (progn
- (edebug-on-entry func 'temp)
- (edebug-go-mode nil)))))
-
- (defun edebug-on-entry (function &optional flag)
- "Cause Edebug to stop when FUNCTION is called.
- With prefix argument, make this temporary so it is automatically
- cancelled the first time the function is entered."
- (interactive "aEdebug on entry to: \nP")
- ;; Could store this in the edebug data instead.
- (put function 'edebug-on-entry (if flag 'temp t)))
-
- (defun cancel-edebug-on-entry (function)
- (interactive "aEdebug on entry to: ")
- (put function 'edebug-on-entry nil))
-
-
- (if (not (fboundp 'edebug-original-debug-on-entry))
- (fset 'edebug-original-debug-on-entry (symbol-function 'debug-on-entry)))
- '(fset 'debug-on-entry 'edebug-debug-on-entry) ;; Should we do this?
- ;; Also need edebug-cancel-debug-on-entry
-
- '(defun edebug-debug-on-entry (function)
- "Request FUNCTION to invoke debugger each time it is called.
- If the user continues, FUNCTION's execution proceeds.
- Works by modifying the definition of FUNCTION,
- which must be written in Lisp, not predefined.
- Use `cancel-debug-on-entry' to cancel the effect of this command.
- Redefining FUNCTION also does that.
-
- This version is from Edebug. If the function is instrumented for
- Edebug, it calls `edebug-on-entry'"
- (interactive "aDebug on entry (to function): ")
- (let ((func-data (get function 'edebug)))
- (if (or (null func-data) (markerp func-data))
- (edebug-original-debug-on-entry function)
- (edebug-on-entry function))))
-
-
- (defun edebug-top-level-nonstop ()
- "Set mode to Go-nonstop, and exit to top-level.
- This is useful for exiting even if unwind-protect code may be executed."
- (interactive)
- (setq edebug-execution-mode 'Go-nonstop)
- (top-level))
-
-
- ;;(defun edebug-exit-out ()
- ;; "Go until the current function exits."
- ;; (interactive)
- ;; (edebug-set-mode 'exiting "Exit..."))
-
-
- ;;; The following initial mode setting definitions are not used yet.
-
- '(defconst edebug-initial-mode-alist
- '((edebug-Continue-fast . Continue-fast)
- (edebug-Trace-fast . Trace-fast)
- (edebug-continue . continue)
- (edebug-trace . trace)
- (edebug-go . go)
- (edebug-step-through . step)
- (edebug-Go-nonstop . Go-nonstop)
- )
- "Association list between commands and the modes they set.")
-
-
- '(defun edebug-set-initial-mode ()
- "Ask for the initial mode of the enclosing function.
- The mode is requested via the key that would be used to set the mode in
- edebug-mode."
- (interactive)
- (let* ((this-function (edebug-which-function))
- (keymap (if (eq edebug-mode-map (current-local-map))
- edebug-mode-map))
- (old-mode (or (get this-function 'edebug-initial-mode)
- edebug-initial-mode))
- (key (read-key-sequence
- (format
- "Change initial edebug mode for %s from %s (%s) to (enter key): "
- this-function
- old-mode
- (where-is-internal
- (car (rassq old-mode edebug-initial-mode-alist))
- keymap 'firstonly
- ))))
- (mode (cdr (assq (key-binding key) edebug-initial-mode-alist)))
- )
- (if (and mode
- (or (get this-function 'edebug-initial-mode)
- (not (eq mode edebug-initial-mode))))
- (progn
- (put this-function 'edebug-initial-mode mode)
- (message "Initial mode for %s is now: %s"
- this-function mode))
- (error "Key must map to one of the mode changing commands")
- )))
-
- ;;; Evaluation of expressions
-
- (def-edebug-spec edebug-outside-excursion t)
-
- (defmacro edebug-outside-excursion (&rest body)
- "Evaluate an expression list in the outside context.
- Return the result of the last expression."
- (` (save-excursion ; of current-buffer
- (if edebug-save-windows
- (progn
- ;; After excursion, we will
- ;; restore to current window configuration.
- (setq edebug-inside-windows
- (edebug-current-windows edebug-save-windows))
- ;; Restore outside windows.
- (edebug-set-windows edebug-outside-windows)))
-
- (set-buffer edebug-buffer) ; why?
- ;; (use-local-map edebug-outside-map)
- (store-match-data edebug-outside-match-data)
- ;; Restore outside context.
- (let (;; (edebug-inside-map (current-local-map)) ;; restore map??
- (last-command-char edebug-outside-last-command-char)
- (last-command-event edebug-outside-last-command-event)
- (last-command edebug-outside-last-command)
- (this-command edebug-outside-this-command)
- (unread-command-char edebug-outside-unread-command-char)
- (unread-command-event edebug-outside-unread-command-event)
- (unread-command-events edebug-outside-unread-command-events)
- (last-input-char edebug-outside-last-input-char)
- (last-input-event edebug-outside-last-input-event)
- (last-event-frame edebug-outside-last-event-frame)
- (last-nonmenu-event edebug-outside-last-nonmenu-event)
- (track-mouse edebug-outside-track-mouse)
- (standard-output edebug-outside-standard-output)
- (standard-input edebug-outside-standard-input)
-
- (executing-kbd-macro edebug-outside-executing-macro)
- (defining-kbd-macro edebug-outside-defining-kbd-macro)
- (pre-command-hook edebug-outside-pre-command-hook)
- (post-command-hook edebug-outside-post-command-hook)
- (post-command-idle-hook edebug-outside-post-command-idle-hook)
-
- ;; See edebug-display
- (overlay-arrow-position edebug-outside-o-a-p)
- (overlay-arrow-string edebug-outside-o-a-s)
- (cursor-in-echo-area edebug-outside-c-i-e-a)
- )
- (unwind-protect
- (save-excursion ; of edebug-buffer
- (set-buffer edebug-outside-buffer)
- (goto-char edebug-outside-point)
- (if (marker-buffer (edebug-mark-marker))
- (set-marker (edebug-mark-marker) edebug-outside-mark))
- (,@ body))
-
- ;; Back to edebug-buffer. Restore rest of inside context.
- ;; (use-local-map edebug-inside-map)
- (if edebug-save-windows
- ;; Restore inside windows.
- (edebug-set-windows edebug-inside-windows))
-
- ;; Save values that may have been changed.
- (setq
- edebug-outside-last-command-char last-command-char
- edebug-outside-last-command-event last-command-event
- edebug-outside-last-command last-command
- edebug-outside-this-command this-command
- edebug-outside-unread-command-char unread-command-char
- edebug-outside-unread-command-event unread-command-event
- edebug-outside-unread-command-events unread-command-events
- edebug-outside-last-input-char last-input-char
- edebug-outside-last-input-event last-input-event
- edebug-outside-last-event-frame last-event-frame
- edebug-outside-last-nonmenu-event last-nonmenu-event
- edebug-outside-track-mouse track-mouse
- edebug-outside-standard-output standard-output
- edebug-outside-standard-input standard-input
-
- edebug-outside-executing-macro executing-kbd-macro
- edebug-outside-defining-kbd-macro defining-kbd-macro
- edebug-outside-pre-command-hook pre-command-hook
- edebug-outside-post-command-hook post-command-hook
- edebug-outside-post-command-idle-hook post-command-idle-hook
-
- edebug-outside-o-a-p overlay-arrow-position
- edebug-outside-o-a-s overlay-arrow-string
- edebug-outside-c-i-e-a cursor-in-echo-area
- ))) ; let
- )))
-
- (defvar cl-debug-env nil) ;; defined in cl; non-nil when lexical env used.
-
- (defun edebug-eval (edebug-expr)
- ;; Are there cl lexical variables active?
- (if cl-debug-env
- (eval (cl-macroexpand-all edebug-expr cl-debug-env))
- (eval edebug-expr)))
-
- (defun edebug-safe-eval (edebug-expr)
- ;; Evaluate EXPR safely.
- ;; If there is an error, a string is returned describing the error.
- (condition-case edebug-err
- (edebug-eval edebug-expr)
- (error (edebug-format "%s: %s" ;; could
- (get (car edebug-err) 'error-message)
- (car (cdr edebug-err))))))
-
- ;;; Printing
-
- ;; Replace printing functions.
-
- ;; obsolete names
- (defalias 'edebug-install-custom-print-funcs 'edebug-install-custom-print)
- (defalias 'edebug-reset-print-funcs 'edebug-uninstall-custom-print)
- (defalias 'edebug-uninstall-custom-print-funcs 'edebug-uninstall-custom-print)
-
- (defun edebug-install-custom-print ()
- "Replace print functions used by Edebug with custom versions."
- ;; Modifying the custom print functions, or changing print-length,
- ;; print-level, print-circle, custom-print-list or custom-print-vector
- ;; have immediate effect.
- (interactive)
- (require 'cust-print)
- (defalias 'edebug-prin1 'custom-prin1)
- (defalias 'edebug-print 'custom-print)
- (defalias 'edebug-prin1-to-string 'custom-prin1-to-string)
- (defalias 'edebug-format 'custom-format)
- (defalias 'edebug-message 'custom-message)
- "Installed")
-
- (eval-and-compile
- (defun edebug-uninstall-custom-print ()
- "Replace edebug custom print functions with internal versions."
- (interactive)
- (defalias 'edebug-prin1 'prin1)
- (defalias 'edebug-print 'print)
- (defalias 'edebug-prin1-to-string 'prin1-to-string)
- (defalias 'edebug-format 'format)
- (defalias 'edebug-message 'message)
- "Uninstalled")
-
- ;; Default print functions are the same as Emacs'.
- (edebug-uninstall-custom-print))
-
-
- (defun edebug-report-error (edebug-value)
- ;; Print an error message like command level does.
- ;; This also prints the error name if it has no error-message.
- (message "%s: %s"
- (or (get (car edebug-value) 'error-message)
- (format "peculiar error (%s)" (car edebug-value)))
- (mapconcat (function (lambda (edebug-arg)
- ;; continuing after an error may
- ;; complain about edebug-arg. why??
- (prin1-to-string edebug-arg)))
- (cdr edebug-value) ", ")))
-
- ;; Define here in case they are not already defined.
- (defvar print-level nil)
- (defvar print-circle nil)
- (defvar print-readably) ;; defined by lemacs
- ;; Alternatively, we could change the definition of
- ;; edebug-safe-prin1-to-string to only use these if defined.
-
- (defun edebug-safe-prin1-to-string (value)
- (let ((print-escape-newlines t)
- (print-length (or edebug-print-length print-length))
- (print-level (or edebug-print-level print-level))
- (print-circle (or edebug-print-circle print-circle))
- (print-readably nil)) ;; lemacs uses this.
- (edebug-prin1-to-string value)))
-
- (defun edebug-compute-previous-result (edebug-previous-value)
- (setq edebug-previous-result
- (if (and (numberp edebug-previous-value)
- (< edebug-previous-value 256)
- (>= edebug-previous-value 0))
- (format "Result: %s = %s" edebug-previous-value
- (single-key-description edebug-previous-value))
- (if edebug-unwrap-results
- (setq edebug-previous-value
- (edebug-unwrap* edebug-previous-value)))
- (concat "Result: "
- (edebug-safe-prin1-to-string edebug-previous-value)))))
-
- (defun edebug-previous-result ()
- "Print the previous result."
- (interactive)
- (message "%s" edebug-previous-result))
-
- ;;; Read, Eval and Print
-
- (defun edebug-eval-expression (edebug-expr)
- "Evaluate an expression in the outside environment.
- If interactive, prompt for the expression.
- Print result in minibuffer."
- (interactive "xEval: ")
- (princ
- (edebug-outside-excursion
- (setq values (cons (edebug-eval edebug-expr) values))
- (edebug-safe-prin1-to-string (car values)))))
-
- (defun edebug-eval-last-sexp ()
- "Evaluate sexp before point in the outside environment;
- print value in minibuffer."
- (interactive)
- (edebug-eval-expression (edebug-last-sexp)))
-
- (defun edebug-eval-print-last-sexp ()
- "Evaluate sexp before point in the outside environment;
- print value into current buffer."
- (interactive)
- (let* ((edebug-form (edebug-last-sexp))
- (edebug-result-string
- (edebug-outside-excursion
- (edebug-safe-prin1-to-string (edebug-safe-eval edebug-form))))
- (standard-output (current-buffer)))
- (princ "\n")
- ;; princ the string to get rid of quotes.
- (princ edebug-result-string)
- (princ "\n")
- ))
-
- ;;; Edebug Minor Mode
-
- ;; Global GUD bindings for all emacs-lisp-mode buffers.
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-s" 'edebug-step-mode)
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-n" 'edebug-next-mode)
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-c" 'edebug-go-mode)
- (define-key emacs-lisp-mode-map "\C-x\C-a\C-l" 'edebug-where)
-
-
- (defvar edebug-mode-map nil)
- (if edebug-mode-map
- nil
- (progn
- (setq edebug-mode-map (copy-keymap emacs-lisp-mode-map))
- ;; control
- (define-key edebug-mode-map " " 'edebug-step-mode)
- (define-key edebug-mode-map "n" 'edebug-next-mode)
- (define-key edebug-mode-map "g" 'edebug-go-mode)
- (define-key edebug-mode-map "G" 'edebug-Go-nonstop-mode)
- (define-key edebug-mode-map "t" 'edebug-trace-mode)
- (define-key edebug-mode-map "T" 'edebug-Trace-fast-mode)
- (define-key edebug-mode-map "c" 'edebug-continue-mode)
- (define-key edebug-mode-map "C" 'edebug-Continue-fast-mode)
-
- ;;(define-key edebug-mode-map "f" 'edebug-forward) not implemented
- (define-key edebug-mode-map "f" 'edebug-forward-sexp)
- (define-key edebug-mode-map "h" 'edebug-goto-here)
-
- (define-key edebug-mode-map "I" 'edebug-instrument-callee)
- (define-key edebug-mode-map "i" 'edebug-step-in)
- (define-key edebug-mode-map "o" 'edebug-step-out)
-
- ;; quitting and stopping
- (define-key edebug-mode-map "q" 'top-level)
- (define-key edebug-mode-map "Q" 'edebug-top-level-nonstop)
- (define-key edebug-mode-map "a" 'abort-recursive-edit)
- (define-key edebug-mode-map "S" 'edebug-stop)
-
- ;; breakpoints
- (define-key edebug-mode-map "b" 'edebug-set-breakpoint)
- (define-key edebug-mode-map "u" 'edebug-unset-breakpoint)
- (define-key edebug-mode-map "B" 'edebug-next-breakpoint)
- (define-key edebug-mode-map "x" 'edebug-set-conditional-breakpoint)
- (define-key edebug-mode-map "X" 'edebug-set-global-break-condition)
-
- ;; evaluation
- (define-key edebug-mode-map "r" 'edebug-previous-result)
- (define-key edebug-mode-map "e" 'edebug-eval-expression)
- (define-key edebug-mode-map "\C-x\C-e" 'edebug-eval-last-sexp)
- (define-key edebug-mode-map "E" 'edebug-visit-eval-list)
-
- ;; views
- (define-key edebug-mode-map "w" 'edebug-where)
- (define-key edebug-mode-map "v" 'edebug-view-outside) ;; maybe obsolete??
- (define-key edebug-mode-map "p" 'edebug-bounce-point)
- (define-key edebug-mode-map "P" 'edebug-view-outside) ;; same as v
- (define-key edebug-mode-map "W" 'edebug-toggle-save-windows)
-
- ;; misc
- (define-key edebug-mode-map "?" 'edebug-help)
- (define-key edebug-mode-map "d" 'edebug-backtrace)
-
- (define-key edebug-mode-map "-" 'negative-argument)
-
- ;; statistics
- (define-key edebug-mode-map "=" 'edebug-temp-display-freq-count)
-
- ;; GUD bindings
- (define-key edebug-mode-map "\C-c\C-s" 'edebug-step-mode)
- (define-key edebug-mode-map "\C-c\C-n" 'edebug-next-mode)
- (define-key edebug-mode-map "\C-c\C-c" 'edebug-go-mode)
-
- (define-key edebug-mode-map "\C-x " 'edebug-set-breakpoint)
- (define-key edebug-mode-map "\C-c\C-d" 'edebug-unset-breakpoint)
- (define-key edebug-mode-map "\C-c\C-t"
- (function (lambda () (edebug-set-breakpoint t))))
- (define-key edebug-mode-map "\C-c\C-l" 'edebug-where)
- ))
-
- ;; Autoloading these global bindings doesn't make sense because
- ;; they cannot be used anyway unless Edebug is already loaded and active.
-
- (defvar global-edebug-prefix "\^XX"
- "Prefix key for global edebug commands, available from any buffer.")
-
- (defvar global-edebug-map nil
- "Global map of edebug commands, available from any buffer.")
-
- (if global-edebug-map
- nil
- (setq global-edebug-map (make-sparse-keymap))
-
- (global-unset-key global-edebug-prefix)
- (global-set-key global-edebug-prefix global-edebug-map)
-
- (define-key global-edebug-map " " 'edebug-step-mode)
- (define-key global-edebug-map "g" 'edebug-go-mode)
- (define-key global-edebug-map "G" 'edebug-Go-nonstop-mode)
- (define-key global-edebug-map "t" 'edebug-trace-mode)
- (define-key global-edebug-map "T" 'edebug-Trace-fast-mode)
- (define-key global-edebug-map "c" 'edebug-continue-mode)
- (define-key global-edebug-map "C" 'edebug-Continue-fast-mode)
-
- ;; breakpoints
- (define-key global-edebug-map "b" 'edebug-set-breakpoint)
- (define-key global-edebug-map "u" 'edebug-unset-breakpoint)
- (define-key global-edebug-map "x" 'edebug-set-conditional-breakpoint)
- (define-key global-edebug-map "X" 'edebug-set-global-break-condition)
-
- ;; views
- (define-key global-edebug-map "w" 'edebug-where)
- (define-key global-edebug-map "W" 'edebug-toggle-save-windows)
-
- ;; quitting
- (define-key global-edebug-map "q" 'top-level)
- (define-key global-edebug-map "Q" 'edebug-top-level-nonstop)
- (define-key global-edebug-map "a" 'abort-recursive-edit)
-
- ;; statistics
- (define-key global-edebug-map "=" 'edebug-display-freq-count)
- )
-
- (defun edebug-help ()
- (interactive)
- (describe-function 'edebug-mode))
-
- (defun edebug-mode ()
- "Mode for Emacs Lisp buffers while in Edebug.
-
- In addition to all Emacs Lisp commands (except those that modify the
- buffer) there are local and global key bindings to several Edebug
- specific commands. E.g. `edebug-step-mode' is bound to \\[edebug-step-mode]
- in the Edebug buffer and \\<global-map>\\[edebug-step-mode] in any buffer.
-
- Also see bindings for the eval list buffer, *edebug*.
-
- The edebug buffer commands:
- \\{edebug-mode-map}
-
- Global commands prefixed by `global-edebug-prefix':
- \\{global-edebug-map}
-
- Options:
- edebug-setup-hook
- edebug-all-defs
- edebug-all-forms
- edebug-save-windows
- edebug-save-displayed-buffer-points
- edebug-initial-mode
- edebug-trace
- edebug-test-coverage
- edebug-continue-kbd-macro
- edebug-print-length
- edebug-print-level
- edebug-print-circle
- edebug-on-error
- edebug-on-quit
- edebug-on-signal
- edebug-unwrap-results
- edebug-global-break-condition
- "
- (use-local-map edebug-mode-map))
-
- ;;; edebug eval list mode
-
- ;; A list of expressions and their evaluations is displayed in *edebug*.
-
- (defun edebug-eval-result-list ()
- "Return a list of evaluations of edebug-eval-list"
- ;; Assumes in outside environment.
- ;; Don't do any edebug things now.
- (let ((edebug-execution-mode 'Go-nonstop)
- (edebug-trace nil))
- (mapcar 'edebug-safe-eval edebug-eval-list)))
-
- (defun edebug-eval-display-list (edebug-eval-result-list)
- ;; Assumes edebug-eval-buffer exists.
- (let ((edebug-eval-list-temp edebug-eval-list)
- (standard-output edebug-eval-buffer)
- (edebug-comment-line
- (format ";%s\n" (make-string (- (window-width) 2) ?-))))
- (set-buffer edebug-eval-buffer)
- (erase-buffer)
- (while edebug-eval-list-temp
- (prin1 (car edebug-eval-list-temp)) (terpri)
- (prin1 (car edebug-eval-result-list)) (terpri)
- (princ edebug-comment-line)
- (setq edebug-eval-list-temp (cdr edebug-eval-list-temp))
- (setq edebug-eval-result-list (cdr edebug-eval-result-list)))
- (edebug-pop-to-buffer edebug-eval-buffer)
- ))
-
- (defun edebug-create-eval-buffer ()
- (if (not (and edebug-eval-buffer (buffer-name edebug-eval-buffer)))
- (progn
- (set-buffer (setq edebug-eval-buffer (get-buffer-create "*edebug*")))
- (edebug-eval-mode))))
-
- ;; Should generalize this to be callable outside of edebug
- ;; with calls in user functions, e.g. (edebug-eval-display)
-
- (defun edebug-eval-display (edebug-eval-result-list)
- "Display expressions and evaluations in EVAL-LIST.
- It modifies the context by popping up the eval display."
- (if edebug-eval-result-list
- (progn
- (edebug-create-eval-buffer)
- (edebug-eval-display-list edebug-eval-result-list)
- )))
-
- (defun edebug-eval-redisplay ()
- "Redisplay eval list in outside environment.
- May only be called from within edebug-recursive-edit."
- (edebug-create-eval-buffer)
- (edebug-outside-excursion
- (edebug-eval-display-list (edebug-eval-result-list))
- ))
-
- (defun edebug-visit-eval-list ()
- (interactive)
- (edebug-eval-redisplay)
- (edebug-pop-to-buffer edebug-eval-buffer))
-
-
- (defun edebug-update-eval-list ()
- "Replace the evaluation list with the sexps now in the eval buffer."
- (interactive)
- (let ((starting-point (point))
- new-list)
- (goto-char (point-min))
- ;; get the first expression
- (edebug-skip-whitespace)
- (if (not (eobp))
- (progn
- (forward-sexp 1)
- (setq new-list (cons (edebug-last-sexp) new-list))))
-
- (while (re-search-forward "^;" nil t)
- (forward-line 1)
- (skip-chars-forward " \t\n\r")
- (if (and (/= ?\; (following-char))
- (not (eobp)))
- (progn
- (forward-sexp 1)
- (setq new-list (cons (edebug-last-sexp) new-list)))))
-
- (setq edebug-eval-list (nreverse new-list))
- (edebug-eval-redisplay)
- (goto-char starting-point)))
-
-
- (defun edebug-delete-eval-item ()
- "Delete the item under point and redisplay."
- ;; could add arg to do repeatedly
- (interactive)
- (if (re-search-backward "^;" nil 'nofail)
- (forward-line 1))
- (delete-region
- (point) (progn (re-search-forward "^;" nil 'nofail)
- (beginning-of-line)
- (point)))
- (edebug-update-eval-list))
-
-
-
- (defvar edebug-eval-mode-map nil
- "Keymap for edebug-eval-mode. Superset of lisp-interaction-mode.")
-
- (if edebug-eval-mode-map
- nil
- (setq edebug-eval-mode-map (copy-keymap lisp-interaction-mode-map))
-
- (define-key edebug-eval-mode-map "\C-c\C-w" 'edebug-where)
- (define-key edebug-eval-mode-map "\C-c\C-d" 'edebug-delete-eval-item)
- (define-key edebug-eval-mode-map "\C-c\C-u" 'edebug-update-eval-list)
- (define-key edebug-eval-mode-map "\C-x\C-e" 'edebug-eval-last-sexp)
- (define-key edebug-eval-mode-map "\C-j" 'edebug-eval-print-last-sexp)
- )
-
-
- (defun edebug-eval-mode ()
- "Mode for evaluation list buffer while in Edebug.
-
- In addition to all Interactive Emacs Lisp commands there are local and
- global key bindings to several Edebug specific commands. E.g.
- `edebug-step-mode' is bound to \\[edebug-step-mode] in the Edebug
- buffer and \\<global-map>\\[edebug-step-mode] in any buffer.
-
- Eval list buffer commands:
- \\{edebug-eval-mode-map}
-
- Global commands prefixed by global-edebug-prefix:
- \\{global-edebug-map}
- "
- (lisp-interaction-mode)
- (setq major-mode 'edebug-eval-mode)
- (setq mode-name "Edebug-Eval")
- (use-local-map edebug-eval-mode-map))
-
- ;;; Interface with standard debugger.
-
- ;; (setq debugger 'edebug) ; to use the edebug debugger
- ;; (setq debugger 'debug) ; use the standard debugger
-
- ;; Note that debug and its utilities must be byte-compiled to work,
- ;; since they depend on the backtrace looking a certain way. But
- ;; edebug is not dependent on this, yet.
-
- (defun edebug (&optional edebug-arg-mode &rest debugger-args)
- "Replacement for debug.
- If we are running an edebugged function,
- show where we last were. Otherwise call debug normally."
- ;; (message "entered: %s depth: %s edebug-recursion-depth: %s"
- ;; edebug-entered (recursion-depth) edebug-recursion-depth) (sit-for 1)
- (if (and edebug-entered ; anything active?
- (eq (recursion-depth) edebug-recursion-depth))
- (let (;; Where were we before the error occurred?
- (edebug-offset-index (car edebug-offset-indices))
- ;; Bind variables required by edebug-display
- (edebug-value (car debugger-args))
- edebug-breakpoints
- edebug-break-data
- edebug-break-condition
- edebug-global-break
- (edebug-break (null edebug-arg-mode)) ;; if called explicitly
- )
- (edebug-display)
- (if (eq edebug-arg-mode 'error)
- nil
- edebug-value))
-
- ;; Otherwise call debug normally.
- ;; Still need to remove extraneous edebug calls from stack.
- (apply 'debug edebug-arg-mode debugger-args)
- ))
-
-
- (defun edebug-backtrace ()
- "Display a non-working backtrace. Better than nothing..."
- (interactive)
- (if (or (not edebug-backtrace-buffer)
- (null (buffer-name edebug-backtrace-buffer)))
- (setq edebug-backtrace-buffer
- (generate-new-buffer "*Backtrace*"))
- ;; else, could just display edebug-backtrace-buffer
- )
- (with-output-to-temp-buffer (buffer-name edebug-backtrace-buffer)
- (setq edebug-backtrace-buffer standard-output)
- (let ((print-escape-newlines t)
- (print-length 50)
- last-ok-point)
- (backtrace)
-
- ;; Clean up the backtrace.
- ;; Not quite right for current edebug scheme.
- (set-buffer edebug-backtrace-buffer)
- (setq truncate-lines t)
- (goto-char (point-min))
- (setq last-ok-point (point))
- (if t (progn
-
- ;; Delete interspersed edebug internals.
- (while (re-search-forward "^ \(?edebug" nil t)
- (beginning-of-line)
- (cond
- ((looking-at "^ \(edebug-after")
- ;; Previous lines may contain code, so just delete this line
- (setq last-ok-point (point))
- (forward-line 1)
- (delete-region last-ok-point (point)))
-
- ((looking-at "^ edebug")
- (forward-line 1)
- (delete-region last-ok-point (point))
- )))
- )))))
-
-
- ;;; Trace display
-
- (defun edebug-trace-display (buf-name fmt &rest args)
- "In buffer BUF-NAME, display FMT and ARGS at the end and make it visible.
- The buffer is created if it does not exist.
- You must include newlines in FMT to break lines, but one newline is appended."
- ;; e.g.
- ;; (edebug-trace-display "*trace-point*"
- ;; "saving: point = %s window-start = %s"
- ;; (point) (window-start))
- (let* ((oldbuf (current-buffer))
- (selected-window (selected-window))
- (buffer (get-buffer-create buf-name))
- buf-window)
- ;; (message "before pop-to-buffer") (sit-for 1)
- (edebug-pop-to-buffer buffer)
- (setq truncate-lines t)
- (setq buf-window (selected-window))
- (goto-char (point-max))
- (insert (apply 'edebug-format fmt args) "\n")
- ;; Make it visible.
- (vertical-motion (- 1 (window-height)))
- (set-window-start buf-window (point))
- (goto-char (point-max))
- ;; (set-window-point buf-window (point))
- ;; (edebug-sit-for 0)
- (bury-buffer buffer)
- (select-window selected-window)
- (set-buffer oldbuf))
- buf-name)
-
-
- (defun edebug-trace (fmt &rest args)
- "Convenience call to edebug-trace-display using edebug-trace-buffer"
- (apply 'edebug-trace-display edebug-trace-buffer fmt args))
-
-
- ;;; Frequency count and coverage
-
- (defun edebug-display-freq-count ()
- "Display the frequency count data for each line of the current
- definition. The frequency counts are inserted as comment lines after
- each line, and you can undo all insertions with one `undo' command.
-
- The counts are inserted starting under the `(' before an expression
- or the `)' after an expression, or on the last char of a symbol.
- The counts are only displayed when they differ from previous counts on
- the same line.
-
- If coverage is being tested, whenever all known results of an expression
- are `eq', the char `=' will be appended after the count
- for that expression. Note that this is always the case for an
- expression only evaluated once.
-
- To clear the frequency count and coverage data for a definition,
- reinstrument it."
- (interactive)
- (let* ((function (edebug-form-data-symbol))
- (counts (get function 'edebug-freq-count))
- (coverages (get function 'edebug-coverage))
- (data (get function 'edebug))
- (def-mark (car data)) ; mark at def start
- (edebug-points (nth 2 data))
- (i (1- (length edebug-points)))
- (last-index)
- (first-index)
- (start-of-line)
- (start-of-count-line)
- (last-count)
- )
- (save-excursion
- ;; Traverse in reverse order so offsets are correct.
- (while (<= 0 i)
- ;; Start at last expression in line.
- (goto-char (+ def-mark (aref edebug-points i)))
- (beginning-of-line)
- (setq start-of-line (- (point) def-mark)
- last-index i)
-
- ;; Find all indexes on same line.
- (while (and (<= 0 (setq i (1- i)))
- (<= start-of-line (aref edebug-points i))))
- ;; Insert all the indices for this line.
- (forward-line 1)
- (setq start-of-count-line (point)
- first-index i ; really last index for line above this one.
- last-count -1) ; cause first count to always appear.
- (insert ";#")
- ;; i == first-index still
- (while (<= (setq i (1+ i)) last-index)
- (let ((count (aref counts i))
- (coverage (aref coverages i))
- (col (save-excursion
- (goto-char (+ (aref edebug-points i) def-mark))
- (- (current-column)
- (if (= ?\( (following-char)) 0 1)))))
- (insert (make-string
- (max 0 (- col (- (point) start-of-count-line))) ?\ )
- (if (and (< 0 count)
- (not (memq coverage
- '(unknown ok-coverage))))
- "=" "")
- (if (= count last-count) "" (int-to-string count))
- " ")
- (setq last-count count)))
- (insert "\n")
- (setq i first-index)))))
-
- (defun edebug-temp-display-freq-count ()
- "Temporarily display the frequency count data for the current definition.
- It is removed when you hit any char."
- ;; This seems not to work with Emacs 18.59. It undoes too far.
- (interactive)
- (let ((buffer-read-only nil))
- (undo-boundary)
- (edebug-display-freq-count)
- (setq unread-command-char (read-char))
- (undo)))
-
-
- ;;; Menus
-
- (defun edebug-toggle (variable)
- (set variable (not (eval variable)))
- (message "%s: %s" variable (eval variable)))
-
- ;; We have to require easymenu (even for Emacs 18) just so
- ;; the easy-menu-define macro call is compiled correctly.
- (require 'easymenu)
-
- (defconst edebug-mode-menus
- '("Edebug"
- "----"
- ["Stop" edebug-stop t]
- ["Step" edebug-step-mode t]
- ["Next" edebug-next-mode t]
- ["Trace" edebug-trace-mode t]
- ["Trace Fast" edebug-Trace-fast-mode t]
- ["Continue" edebug-continue-mode t]
- ["Continue Fast" edebug-Continue-fast-mode t]
- ["Go" edebug-go-mode t]
- ["Go Nonstop" edebug-Go-nonstop-mode t]
- "----"
- ["Help" edebug-help t]
- ["Abort" abort-recursive-edit t]
- ["Quit to Top Level" top-level t]
- ["Quit Nonstop" edebug-top-level-nonstop t]
- "----"
- ("Jumps"
- ["Forward Sexp" edebug-forward-sexp t]
- ["Step In" edebug-step-in t]
- ["Step Out" edebug-step-out t]
- ["Goto Here" edebug-goto-here t])
-
- ("Breaks"
- ["Set Breakpoint" edebug-set-breakpoint t]
- ["Unset Breakpoint" edebug-unset-breakpoint t]
- ["Set Conditional Breakpoint" edebug-set-conditional-breakpoint t]
- ["Set Global Break Condition" edebug-set-global-break-condition t]
- ["Show Next Breakpoint" edebug-next-breakpoint t])
-
- ("Views"
- ["Where am I?" edebug-where t]
- ["Bounce to Current Point" edebug-bounce-point t]
- ["View Outside Windows" edebug-view-outside t]
- ["Previous Result" edebug-previous-result t]
- ["Show Backtrace" edebug-backtrace t]
- ["Display Freq Count" edebug-display-freq-count t])
-
- ("Eval"
- ["Expression" edebug-eval-expression t]
- ["Last Sexp" edebug-eval-last-sexp t]
- ["Visit Eval List" edebug-visit-eval-list t])
-
- ("Options"
- ["Edebug All Defs" edebug-all-defs t]
- ["Edebug All Forms" edebug-all-forms t]
- "----"
- ["Toggle Tracing" (edebug-toggle 'edebug-trace) t]
- ["Toggle Coverage Testing" (edebug-toggle 'edebug-test-coverage) t]
- ["Toggle Window Saving" edebug-toggle-save-windows t]
- ["Toggle Point Saving"
- (edebug-toggle 'edebug-save-displayed-buffer-points) t]
- ))
- "Lemacs style menus for Edebug.")
-
-
- ;;; Emacs version specific code
-
- ;;; The default for all above is Emacs 18, because it is easier to compile
- ;;; Emacs 18 code in Emacs 19 than vice versa. This default will
- ;;; change once most people are using Emacs 19 or derivatives.
-
- ;; Epoch specific code is in a separate file: edebug-epoch.el.
-
- ;; The byte-compiler will complain about changes in number of arguments
- ;; to functions like mark and read-from-minibuffer. These warnings
- ;; may be ignored because the right call should always be made.
-
- (defun edebug-emacs-19-specific ()
-
- (defalias 'edebug-window-live-p 'window-live-p)
-
- ;; Mark takes an argument in Emacs 19.
- (defun edebug-mark ()
- (mark t));; Does this work for lemacs too?
-
- ;; Use minibuffer-history when reading expressions.
- (defvar read-expression-history) ;; hush bytecomp
- (defvar read-expression-map)
-
- (defun edebug-set-conditional-breakpoint (arg condition)
- "Set a conditional breakpoint at nearest sexp.
- The condition is evaluated in the outside context.
- With prefix argument, make it a temporary breakpoint."
- ;; (interactive "P\nxCondition: ")
- (interactive
- (list
- current-prefix-arg
- ;; Read condition as follows; getting previous condition is cumbersome:
- (let ((edebug-stop-point (edebug-find-stop-point)))
- (if edebug-stop-point
- (let* ((edebug-def-name (car edebug-stop-point))
- (index (cdr edebug-stop-point))
- (edebug-data (get edebug-def-name 'edebug))
- (edebug-breakpoints (car (cdr edebug-data)))
- (edebug-break-data (assq index edebug-breakpoints))
- (edebug-break-condition (car (cdr edebug-break-data)))
- (edebug-expression-history
- ;; Prepend the current condition, if any.
- (if edebug-break-condition
- (cons edebug-break-condition read-expression-history)
- read-expression-history)))
- (prog1
- (read-from-minibuffer
- "Condition: " nil read-expression-map t
- 'edebug-expression-history)
- (setq read-expression-history edebug-expression-history)
- ))))))
- (edebug-modify-breakpoint t condition arg))
-
- (defun edebug-eval-expression (edebug-expr)
- "Evaluate an expression in the outside environment.
- If interactive, prompt for the expression.
- Print result in minibuffer."
- (interactive (list (read-from-minibuffer
- "Eval: " nil read-expression-map t
- 'read-expression-history)))
- (princ
- (edebug-outside-excursion
- (setq values (cons (edebug-eval edebug-expr) values))
- (edebug-safe-prin1-to-string (car values)))))
-
- (easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus)
- (if window-system
- (x-popup-menu nil (lookup-key edebug-mode-map [menu-bar Edebug])))
- )
-
-
- (defun edebug-lemacs-specific ()
-
- ;; We need to bind zmacs-regions to nil around all calls to `mark' and
- ;; `mark-marker' but don't bind it to nil before entering a recursive edit,
- ;; that is, don't interfere with the binding the user might see while
- ;; executing a command.
-
- (defvar zmacs-regions)
-
- (defun edebug-mark ()
- (let ((zmacs-regions nil))
- (mark)))
-
- (defun edebug-mark-marker ()
- (let ((zmacs-regions nil));; for lemacs
- (mark-marker)))
-
-
- (defun edebug-mode-menu (event)
- (interactive "@event")
- (popup-menu edebug-mode-menus))
-
- (define-key edebug-mode-map 'button3 'edebug-mode-menu)
- )
-
- (defun edebug-emacs-version-specific ()
- (cond
- ((string-match "Lucid" emacs-version);; Lucid Emacs
- (edebug-lemacs-specific))
-
- ((and (boundp 'epoch::version) epoch::version)
- (require 'edebug-epoch))
-
- ((not (string-match "^18" emacs-version))
- (edebug-emacs-19-specific))))
-
- (edebug-emacs-version-specific)
-
-
- ;;; Byte-compiler
-
- ;; Extension for bytecomp to resolve undefined function references.
- ;; Requires new byte compiler.
-
- ;; Reenable byte compiler warnings about unread-command-char and -event.
- ;; Disabled before edebug-recursive-edit.
- (eval-when-compile
- (if edebug-unread-command-char-warning
- (put 'unread-command-char 'byte-obsolete-variable
- edebug-unread-command-char-warning))
- (if edebug-unread-command-event-warning
- (put 'unread-command-event 'byte-obsolete-variable
- edebug-unread-command-event-warning)))
-
- (eval-when-compile
- ;; The body of eval-when-compile seems to get evaluated with eval-defun.
- ;; We only want to evaluate when actually byte compiling.
- ;; But it is OK to evaluate as long as byte-compiler has been loaded.
- (if (featurep 'byte-compile) (progn
-
- (defun byte-compile-resolve-functions (funcs)
- "Say it is OK for the named functions to be unresolved."
- (mapcar
- (function
- (lambda (func)
- (setq byte-compile-unresolved-functions
- (delq (assq func byte-compile-unresolved-functions)
- byte-compile-unresolved-functions))))
- funcs)
- nil)
-
- '(defun byte-compile-resolve-free-references (vars)
- "Say it is OK for the named variables to be referenced."
- (mapcar
- (function
- (lambda (var)
- (setq byte-compile-free-references
- (delq var byte-compile-free-references))))
- vars)
- nil)
-
- '(defun byte-compile-resolve-free-assignments (vars)
- "Say it is OK for the named variables to be assigned."
- (mapcar
- (function
- (lambda (var)
- (setq byte-compile-free-assignments
- (delq var byte-compile-free-assignments))))
- vars)
- nil)
-
- (byte-compile-resolve-functions
- '(reporter-submit-bug-report
- edebug-gensym ;; also in cl.el
- ;; Interfaces to standard functions.
- edebug-original-eval-defun
- edebug-original-read
- edebug-get-buffer-window
- edebug-mark
- edebug-mark-marker
- edebug-input-pending-p
- edebug-sit-for
- edebug-prin1-to-string
- edebug-format
- edebug-original-signal
- ;; lemacs
- zmacs-deactivate-region
- popup-menu
- ;; CL
- cl-macroexpand-all
- ;; And believe it or not, the byte compiler doesn't know about:
- byte-compile-resolve-functions
- ))
-
- '(byte-compile-resolve-free-references
- '(read-expression-history
- read-expression-map))
-
- '(byte-compile-resolve-free-assignments
- '(read-expression-history))
-
- )))
-
-
- ;;; Autoloading of Edebug accessories
-
- (if (featurep 'cl)
- (add-hook 'edebug-setup-hook
- (function (lambda () (require 'cl-specs))))
- ;; The following causes cl-specs to be loaded if you load cl.el.
- (add-hook 'cl-load-hook
- (function (lambda () (require 'cl-specs)))))
-
- ;;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu
- (if (featurep 'cl-read)
- (add-hook 'edebug-setup-hook
- (function (lambda () (require 'edebug-cl-read))))
- ;; The following causes edebug-cl-read to be loaded when you load cl-read.el.
- (add-hook 'cl-read-load-hooks
- (function (lambda () (require 'edebug-cl-read)))))
-
-
- ;;; Finalize Loading
-
- ;;; Finally, hook edebug into the rest of Emacs.
- ;;; There are probably some other things that could go here.
-
- ;; Install edebug read and eval functions.
- (edebug-install-read-eval-functions)
-
- (provide 'edebug)
-
- ;;; edebug.el ends here
-